vulkan-tutorial/src/Devices.hs

254 lines
8 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Devices where
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Data.Maybe (fromMaybe, isNothing)
2022-07-12 14:58:25 +00:00
import Data.Bits
2022-07-13 17:25:10 +00:00
import Data.Word (Word32)
import Foreign.C.Types (CInt)
import Linear
import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
2022-12-28 03:18:54 +00:00
import qualified VulkanMemoryAllocator as VMA
-- internal imports
import Image
import Types
pickPhysicalDevice
:: (MonadResource m)
=> Vk.Instance
-> m Vk.PhysicalDevice
pickPhysicalDevice vkInstance = do
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
2022-07-11 03:21:57 +00:00
devicesWithPropsAndFeatures <- V.mapM
(\device -> do
devProps <- Vk.getPhysicalDeviceProperties device
2022-07-11 03:21:57 +00:00
devFeatures <- Vk.getPhysicalDeviceFeatures device
return (device, devProps, devFeatures)
)
physDevices
let discretePhysDevices = V.filter
2023-01-16 00:10:23 +00:00
(\(_, devProps, devFeatures) ->
Vk.deviceType devProps == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
2022-07-11 03:21:57 +00:00
Vk.geometryShader devFeatures
)
devicesWithPropsAndFeatures
(maxMemdiscretePhysDevice, props,_ ) = V.foldl
2022-07-11 03:21:57 +00:00
(\acc@(_, devProp1, _) ndev@(_, devProp2, _) ->
let dimension = Vk.maxImageDimension2D . Vk.limits
in
if dimension devProp1 < dimension devProp2
then ndev
else acc
)
(V.head discretePhysDevices)
discretePhysDevices
liftIO $ do
putStrLn "picked the following device:"
print (Vk.deviceName props)
return maxMemdiscretePhysDevice
2022-07-13 17:25:10 +00:00
getQueueFamily
:: (MonadResource m)
=> Vk.PhysicalDevice
2022-07-13 17:25:10 +00:00
-> Vk.QueueFlagBits
-> m Word32
getQueueFamily physicalDevice distinctBit = do
2022-07-13 17:25:10 +00:00
queueFamilyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties physicalDevice
liftIO $ do
putStrLn "There are currently following queue families available"
2022-07-13 17:25:10 +00:00
print queueFamilyProperties
2022-07-13 17:25:10 +00:00
let queueFamily = V.foldl
(\acc (index, qFamily) ->
if Vk.queueFlags qFamily .&. distinctBit /= zeroBits && isNothing acc
2022-07-12 14:58:25 +00:00
then Just index
else acc
)
Nothing
2022-07-13 17:25:10 +00:00
(V.zip (V.fromList [0..]) queueFamilyProperties)
return $ fromMaybe
(error "getQueueFamilies: The requested queueFamily doesn't seem to exist")
queueFamily
createLogicalDevice
:: (MonadResource m)
=> Vk.PhysicalDevice
-> Vk.SurfaceKHR
-> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
createLogicalDevice physDevice surface = do
graphicsQueueFamily <- getQueueFamily physDevice Vk.QUEUE_GRAPHICS_BIT
2022-07-12 14:58:25 +00:00
let priorities = V.singleton 1
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
queueCreateInfo = Vk.zero
2022-07-13 17:25:10 +00:00
{ Vk.queueFamilyIndex = graphicsQueueFamily
2022-07-11 12:04:42 +00:00
, Vk.queuePriorities = priorities
}
deviceCreateInfo = Vk.zero
2022-07-11 12:04:42 +00:00
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
, Vk.enabledExtensionNames = extensionNames
}
(_, logDevice) <- allocate
(Vk.createDevice physDevice deviceCreateInfo Nothing)
(\logDevice -> do
putStrLn "destroying logical device"
Vk.destroyDevice logDevice Nothing
)
(result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface
unless (result == Vk.SUCCESS) $
2022-07-12 14:58:25 +00:00
error "createLogicalDevice: Failed retrieving surface image formats"
return (logDevice, formats)
createSwapchain
:: (MonadResource m)
=> Vk.SurfaceKHR
-> V.Vector Vk.SurfaceFormatKHR
-> V2 CInt
-> Vk.Device
2022-12-28 03:18:54 +00:00
-> VMA.Allocator
-> m (Vk.SwapchainKHR, Vk.SurfaceFormatKHR, Vk.ImageView, AllocatedImage)
createSwapchain surface surfaceFormats windowDimension logicalDevice allocator = do
liftIO $ do
putStrLn "available formats:"
print surfaceFormats
2022-07-11 12:01:04 +00:00
(surfaceFormat, colorSpace) <-
if
V.any
(\a ->
(Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) a ==
Vk.FORMAT_B8G8R8A8_SRGB
&& (Vk.colorSpace :: Vk.SurfaceFormatKHR -> Vk.ColorSpaceKHR) a ==
Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR)
surfaceFormats
then
return (Vk.FORMAT_B8G8R8A8_SRGB, Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR)
else
error ("createSwapchain: No suitable surface formats available" :: String)
liftIO $ do
putStrLn "picking following format and color space:"
2022-07-11 12:01:04 +00:00
print (surfaceFormat, colorSpace)
let createInfo = Vk.zero
2022-07-11 12:01:04 +00:00
{ Vk.surface = surface
, Vk.minImageCount = 4
, Vk.imageFormat = surfaceFormat
, Vk.imageColorSpace = colorSpace
, Vk.imageExtent =
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
, Vk.imageArrayLayers = 1
2022-07-11 12:01:04 +00:00
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
2022-07-14 09:02:12 +00:00
, Vk.presentMode = Vk.PRESENT_MODE_FIFO_KHR
2022-07-11 12:01:04 +00:00
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR
, Vk.clipped = True
}
2022-07-11 12:01:04 +00:00
swapchain <- snd <$> allocate
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
(\swapchain -> do
putStrLn "destroying swapchain"
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
)
2022-12-28 03:18:54 +00:00
let depthImageExtent =
(\(V2 w h) -> Vk.Extent3D (fromIntegral w) (fromIntegral h) 1)
windowDimension
let depthImageInfo = imageCreate
Vk.FORMAT_D32_SFLOAT
depthImageExtent
Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT
let depthImageAllocationInfo = Vk.zero
{ VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
, VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
(depthImage, depthAllocation, _) <- snd <$> allocate
(VMA.createImage allocator depthImageInfo depthImageAllocationInfo)
(\(depthImage, depthAllocation, _) -> do
putStrLn "destroying image"
VMA.destroyImage allocator depthImage depthAllocation
)
let allocatedImage = AllocatedImage depthImage depthAllocation
depthImageView = imageviewCreate
(image allocatedImage)
Vk.FORMAT_D32_SFLOAT
Vk.IMAGE_ASPECT_DEPTH_BIT
depthImageview <- snd <$> allocate
(Vk.createImageView logicalDevice depthImageView Nothing)
(\depthImageview -> do
putStrLn "destroying image view"
Vk.destroyImageView logicalDevice depthImageview Nothing
)
return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace, depthImageview, allocatedImage)
2022-07-11 12:01:04 +00:00
getImageViewHandles
:: (MonadResource m)
=> Vk.SwapchainKHR
2022-07-11 12:01:04 +00:00
-> Vk.SurfaceFormatKHR
-> Vk.Device
-> m (V.Vector Vk.ImageView)
2022-07-11 12:01:04 +00:00
getImageViewHandles swapchain surfaceFormat logicalDevice = do
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
when (result /= Vk.SUCCESS) $
error "getImageHandles: Failed acquiring images from swapchain"
2022-07-16 14:36:51 +00:00
liftIO $
putStrLn ("number of images: " <> show (V.length handles))
2022-07-11 12:01:04 +00:00
V.mapM
2022-12-28 03:18:54 +00:00
(\tmpImage -> do
let createInfo = Vk.zero
2022-12-28 03:18:54 +00:00
{ Vk.image = tmpImage
2022-07-11 12:01:04 +00:00
, Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D
, Vk.format = (Vk.format :: Vk.SurfaceFormatKHR -> Vk.Format) surfaceFormat
, Vk.components = Vk.ComponentMapping
{ Vk.r = Vk.COMPONENT_SWIZZLE_IDENTITY
, Vk.g = Vk.COMPONENT_SWIZZLE_IDENTITY
, Vk.b = Vk.COMPONENT_SWIZZLE_IDENTITY
, Vk.a = Vk.COMPONENT_SWIZZLE_IDENTITY
}
, Vk.subresourceRange = Vk.ImageSubresourceRange
{ aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT
, baseMipLevel = 0
, levelCount = 1
, baseArrayLayer = 0
, layerCount = 1
}
}
2022-07-11 12:01:04 +00:00
snd <$> allocate
(Vk.createImageView logicalDevice createInfo Nothing)
(\imageView -> do
putStrLn "destroying image view"
2022-07-11 12:01:04 +00:00
Vk.destroyImageView logicalDevice imageView Nothing
)
)
2022-07-11 12:01:04 +00:00
handles