diff options
Diffstat (limited to 'VkTest/Util.hs')
| -rw-r--r-- | VkTest/Util.hs | 162 |
1 files changed, 162 insertions, 0 deletions
diff --git a/VkTest/Util.hs b/VkTest/Util.hs new file mode 100644 index 0000000..d92c2dd --- /dev/null +++ b/VkTest/Util.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module VkTest.Util ( withRGFW + , withWindow + , withShaderModules + , withImageViews + , withSemaphores + , withFences + , pickPhysicalDevice + , processExtensions + , getGraphicsQueues + ) where + +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +import Data.Coerce (coerce) +import Data.Int (Int32) +import Data.List ((\\)) +import Data.Vector (Vector) +import Foreign.C +import Foreign.C.ConstPtr (ConstPtr(..)) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) +import Vulkan.Zero (zero) + +import VkTest.Config (QueriedData(..)) + +import qualified VkTest.Config as Config + +import qualified Data.ByteString as BS +import qualified Data.Vector as V +import qualified RGFW as RGFW +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Extensions.VK_KHR_surface as Vk + +pickPhysicalDevice :: Vector Vk.PhysicalDevice -> Vk.SurfaceKHR -> IO (Vk.PhysicalDevice, QueriedData) +pickPhysicalDevice pdevs surface = do + queriedDevs <- do + qs <- V.mapM (\pdev -> (queryPhysicalDevice pdev surface)) pdevs + return $ V.zip pdevs qs + let validpdevs = V.filter isValidPhysicalDevice queriedDevs + pickPhysicalDevice' validpdevs V.empty + +pickPhysicalDevice' :: Vector (Vk.PhysicalDevice, QueriedData) -> Vector (Vk.PhysicalDevice, QueriedData) -> IO (Vk.PhysicalDevice, QueriedData) +pickPhysicalDevice' pdevs opts = + if V.null pdevs + then return $ (V.head opts) + else do + let pdev = V.head pdevs + case (snd pdev).physicalDeviceProperties.deviceType of + Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU -> pickPhysicalDevice' (V.tail pdevs) (V.cons pdev opts) + Vk.PHYSICAL_DEVICE_TYPE_CPU -> pickPhysicalDevice' (V.tail pdevs) opts + _ -> pickPhysicalDevice' (V.tail pdevs) (V.snoc opts pdev) + +-- returns list of queueFamilyIndex whick support a graphics pipeline +getGraphicsQueues :: QueriedData -> [Int] +getGraphicsQueues q = getGraphicsQueues' q.queueFamilyProperties 0 [] +getGraphicsQueues' :: Vector Vk.QueueFamilyProperties -> Int -> [Int] -> [Int] +getGraphicsQueues' qfprops i is = + if V.null qfprops then is else + if zero /= (Vk.QUEUE_GRAPHICS_BIT .&. (V.head qfprops).queueFlags) + then getGraphicsQueues' (V.tail qfprops) (i + 1) (i:is) + else getGraphicsQueues' (V.tail qfprops) (i + 1) is + +-- returns list of queueFamilyIndex which support presentation +getSurfaceSupport :: Vk.PhysicalDevice -> Vk.SurfaceKHR -> IO [Int] +getSurfaceSupport pdev surface = do + qfprops <- Vk.getPhysicalDeviceQueueFamilyProperties pdev + getSurfaceSupport' pdev surface (V.length qfprops - 1) [] + +getSurfaceSupport' :: Vk.PhysicalDevice -> Vk.SurfaceKHR -> Int -> [Int] -> IO [Int] +getSurfaceSupport' pdev surface i is = if i < 0 then return is else do + support <- Vk.getPhysicalDeviceSurfaceSupportKHR pdev (fromIntegral i) surface + if support + then getSurfaceSupport' pdev surface (i - 1) (i:is) + else getSurfaceSupport' pdev surface (i - 1) is + +queryPhysicalDevice :: Vk.PhysicalDevice -> Vk.SurfaceKHR -> IO QueriedData +queryPhysicalDevice pdev surface = do + qfprops <- Vk.getPhysicalDeviceQueueFamilyProperties pdev + sSupport <- getSurfaceSupport pdev surface + (_, extps) <- Vk.enumerateDeviceExtensionProperties pdev Nothing + caps <- Vk.getPhysicalDeviceSurfaceCapabilitiesKHR pdev surface + (_, forms) <- Vk.getPhysicalDeviceSurfaceFormatsKHR pdev surface + props <- Vk.getPhysicalDeviceProperties pdev + return QueriedData { surfaceCapabilities = caps + , surfaceSupport = sSupport + , surfaceFormats = forms + , queueFamilyProperties = qfprops + , extensionProperties = extps + , physicalDeviceProperties = props + } + +-- checks that a device has the requisite capabilities +isValidPhysicalDevice :: (Vk.PhysicalDevice, QueriedData) -> Bool +isValidPhysicalDevice (_, q) = + if null $ getGraphicsQueues q + then False + else if null q.surfaceSupport + then False + else if [] /= ((V.toList Config.extensions) \\ (V.toList $ V.map (\p -> p.extensionName) q.extensionProperties)) + then False + else True + +-- type conversion +processExtensions :: CSize -> Ptr (ConstPtr CChar) -> Vector ByteString -> IO (Vector ByteString) +processExtensions 0 _ extNames = return extNames +processExtensions count strs extNames = do + str <- peek strs + extName <- BS.packCString (coerce str) + processExtensions (count - 1) (advancePtr strs 1) $ V.snoc extNames extName + +withFences :: Vk.Device -> Vector (Vk.FenceCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.Fence -> IO r) -> IO r +withFences dev infos alloc io = do + fs <- mapM (\info -> Vk.createFence dev info alloc) infos + o0 <- io fs + _ <- mapM (\f -> Vk.destroyFence dev f alloc) fs + return o0 + +withSemaphores :: Vk.Device -> Vector (Vk.SemaphoreCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.Semaphore -> IO r) -> IO r +withSemaphores dev infos alloc io = do + ss <- mapM (\info -> Vk.createSemaphore dev info alloc) infos + o0 <- io ss + _ <- mapM (\s -> Vk.destroySemaphore dev s alloc) ss + return o0 + +withImageViews :: Vk.Device -> Vector (Vk.ImageViewCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.ImageView -> IO r) -> IO r +withImageViews dev infos alloc io = do + imageViews <- mapM (\info -> Vk.createImageView dev info alloc) infos + o0 <- io imageViews + _ <- mapM (\imageView -> Vk.destroyImageView dev imageView alloc) imageViews + return o0 + +withShaderModules :: Vk.Device -> Vector (Vk.ShaderModuleCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.ShaderModule -> IO r) -> IO r +withShaderModules dev infos alloc io = do + mods <- mapM (\info -> Vk.createShaderModule dev info alloc) infos + o0 <- io mods + _ <- mapM (\mod' -> Vk.destroyShaderModule dev mod' alloc) mods + return o0 + +withWindow :: String -> Int32 -> Int32 -> Int32 -> Int32 -> RGFW.RGFW_windowFlags -> (Ptr RGFW.RGFW_window -> IO r) -> IO r +withWindow name x y w h flags io = + withCString name $ \str -> do + window <- RGFW.rGFW_createWindow (ConstPtr str) (RGFW.I32 x) (RGFW.I32 y) (RGFW.I32 w) (RGFW.I32 h) flags + o0 <- io window + RGFW.rGFW_window_close window + return o0 + +withRGFW :: String -> RGFW.RGFW_initFlags -> (Int32 -> IO r) -> IO r +withRGFW title flags io = + withCString title $ \str -> do + ret_code <- RGFW.rGFW_init (ConstPtr str) flags + o0 <- io $ fromIntegral ret_code + RGFW.rGFW_deinit + return o0
\ No newline at end of file |