108 lines
3.2 KiB
Haskell
108 lines
3.2 KiB
Haskell
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||
|
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
module Devices where
|
||
|
|
|
||
|
|
import Control.Monad
|
||
|
|
import Control.Monad.Trans.Resource
|
||
|
|
import qualified Data.Vector as V
|
||
|
|
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
|
||
|
|
|
||
|
|
pickPhysicalDevice
|
||
|
|
:: (MonadResource m)
|
||
|
|
=> Vk.Instance
|
||
|
|
-> m Vk.PhysicalDevice
|
||
|
|
pickPhysicalDevice vkInstance = do
|
||
|
|
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
|
||
|
|
|
||
|
|
devicesWithProps <- V.mapM
|
||
|
|
(\device -> do
|
||
|
|
devProps <- Vk.getPhysicalDeviceProperties device
|
||
|
|
return (device, devProps)
|
||
|
|
)
|
||
|
|
physDevices
|
||
|
|
|
||
|
|
let discretePhysDevices = V.filter
|
||
|
|
(\(_, devProp) -> Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU)
|
||
|
|
devicesWithProps
|
||
|
|
maxMemdiscretePhysDevice = fst $ V.foldl
|
||
|
|
(\acc@(_, devProp1) ndev@(_, devProp2) ->
|
||
|
|
let dimension = Vk.maxImageDimension2D . Vk.limits
|
||
|
|
in
|
||
|
|
if dimension devProp1 < dimension devProp2
|
||
|
|
then ndev
|
||
|
|
else acc
|
||
|
|
)
|
||
|
|
(V.head discretePhysDevices)
|
||
|
|
discretePhysDevices
|
||
|
|
|
||
|
|
return maxMemdiscretePhysDevice
|
||
|
|
|
||
|
|
createLogicalDevice
|
||
|
|
:: (MonadResource m)
|
||
|
|
=> Vk.PhysicalDevice
|
||
|
|
-> m Vk.Device
|
||
|
|
createLogicalDevice physDevice = do
|
||
|
|
let priorities = V.singleton 1
|
||
|
|
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
|
||
|
|
queueCreateInfo = Vk.zero
|
||
|
|
{ Vk.queueFamilyIndex = 0
|
||
|
|
, Vk.queuePriorities = priorities
|
||
|
|
}
|
||
|
|
deviceCreateInfo = Vk.zero
|
||
|
|
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
|
||
|
|
, Vk.enabledExtensionNames = extensionNames
|
||
|
|
}
|
||
|
|
|
||
|
|
(_, logDevice) <- allocate
|
||
|
|
(Vk.createDevice physDevice deviceCreateInfo Nothing)
|
||
|
|
(\logDevice -> do
|
||
|
|
print ("destroying logical device" :: String)
|
||
|
|
Vk.destroyDevice logDevice Nothing
|
||
|
|
)
|
||
|
|
|
||
|
|
return logDevice
|
||
|
|
|
||
|
|
createSwapchain
|
||
|
|
:: (MonadResource m)
|
||
|
|
=> Vk.SurfaceKHR
|
||
|
|
-> V2 CInt
|
||
|
|
-> Vk.Device
|
||
|
|
-> m Vk.SwapchainKHR
|
||
|
|
createSwapchain surface windowDimension logicalDevice = do
|
||
|
|
let createInfo = Vk.zero
|
||
|
|
{ Vk.surface = surface
|
||
|
|
, Vk.minImageCount = 4
|
||
|
|
, Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB
|
||
|
|
, Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR
|
||
|
|
, Vk.imageExtent =
|
||
|
|
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
|
||
|
|
, Vk.imageArrayLayers = 1
|
||
|
|
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
|
||
|
|
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
|
||
|
|
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
|
||
|
|
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR
|
||
|
|
}
|
||
|
|
|
||
|
|
snd <$> allocate
|
||
|
|
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
|
||
|
|
(\swapchain -> do
|
||
|
|
print ("destroying Swapchain" :: String)
|
||
|
|
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
|
||
|
|
)
|
||
|
|
|
||
|
|
getImageHandles
|
||
|
|
:: (MonadResource m)
|
||
|
|
=> Vk.SwapchainKHR
|
||
|
|
-> Vk.Device
|
||
|
|
-> m (V.Vector Vk.Image)
|
||
|
|
getImageHandles swapchain logicalDevice = do
|
||
|
|
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
|
||
|
|
when (result /= Vk.SUCCESS) $
|
||
|
|
error "getImageHandles: Failed acquiring images from swapchain"
|
||
|
|
return handles
|