From 0464b823319a520e60f65d6ad2c5f5e5a1ac1953 Mon Sep 17 00:00:00 2001 From: andromeda Date: Fri, 21 Aug 2026 03:34:32 +0200 Subject: modularise --- Main.hs | 396 +++++------------------------------------------------- Shaders.hs | 44 ------ VkTest/Config.hs | 248 ++++++++++++++++++++++++++++++++++ VkTest/Shaders.hs | 43 ++++++ VkTest/Util.hs | 162 ++++++++++++++++++++++ vktest.cabal | 8 +- 6 files changed, 492 insertions(+), 409 deletions(-) delete mode 100644 Shaders.hs create mode 100644 VkTest/Config.hs create mode 100644 VkTest/Shaders.hs create mode 100644 VkTest/Util.hs diff --git a/Main.hs b/Main.hs index 1611a41..d80c533 100644 --- a/Main.hs +++ b/Main.hs @@ -9,223 +9,65 @@ module Main (main) where import Control.Exception (bracket) -import Data.Bits ((.|.), (.&.)) -import Data.ByteString (ByteString) +import Data.Bits ((.|.)) import Data.Coerce (coerce) -import Data.Int (Int32) -import Data.List ((\\)) import Data.Vector (Vector) -import Data.Word (Word32) -import FIR (compileTo, runCompilationsTH) -import Foreign.C -import Foreign.C.ConstPtr (ConstPtr(..)) import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Array (advancePtr) import Foreign.Ptr (Ptr) import Foreign.Storable (peek) import Unsafe.Coerce (unsafeCoerce) import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Zero (zero) +import VkTest.Config (QueriedData(..)) + +import qualified VkTest.Config as Config +import qualified VkTest.Shaders as Shaders +import qualified VkTest.Util as Util + import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC import qualified Data.Vector as V import qualified RGFW as RGFW -import qualified Shaders as Shaders import qualified Vulkan.Core10 as Vk -import qualified Vulkan.Core12 as Vk import qualified Vulkan.Core13 as Vk import qualified Vulkan.Extensions.VK_KHR_surface as Vk import qualified Vulkan.Extensions.VK_KHR_swapchain as Vk -height :: Int32 -height = 400 -width :: Int32 -width = 800 - -layers :: Vector ByteString -layers = V.fromList $ map BSC.pack ["VK_LAYER_KHRONOS_validation"] - -extensions :: Vector ByteString -extensions = V.fromList $ map BSC.pack ["VK_KHR_swapchain"] - -vert = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.vertPath [] Shaders.vertex)] ) -frag = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.fragPath [] Shaders.fragment)] ) - -data Consts = Consts - { title :: String - , vkApiVersion :: Word32 - , framesInFlight :: Word32 - } - deriving Show - -consts = - Consts - { title = "game title" - , vkApiVersion = Vk.API_VERSION_1_3 - , framesInFlight = 2 - } - --- for a given physical device and surface -data QueriedData = QueriedData - { surfaceCapabilities :: Vk.SurfaceCapabilitiesKHR - , surfaceSupport :: [Int] - , surfaceFormats :: Vector Vk.SurfaceFormatKHR - , queueFamilyProperties :: Vector Vk.QueueFamilyProperties - , extensionProperties :: Vector Vk.ExtensionProperties - , physicalDeviceProperties :: Vk.PhysicalDeviceProperties - } - deriving Show - -instanceConfig :: Vector ByteString -> Vk.InstanceCreateInfo '[] -instanceConfig exts = - zero { Vk.applicationInfo = Just (zero :: Vk.ApplicationInfo) { Vk.apiVersion = consts.vkApiVersion } - , Vk.enabledExtensionNames = exts - } - -deviceConfig :: Word32 -> Vk.DeviceCreateInfo '[Vk.PhysicalDeviceVulkan13Features] -deviceConfig gqueueIndex = - zero { Vk.next = (vkFeatures13, ()) - , Vk.queueCreateInfos = V.singleton $ SomeStruct zero { Vk.queueFamilyIndex = gqueueIndex - , Vk.queuePriorities = V.singleton 1 - } - , Vk.enabledExtensionNames = extensions - } - -vkFeatures13 :: Vk.PhysicalDeviceVulkan13Features -vkFeatures13 = - zero { Vk.synchronization2 = True - , Vk.dynamicRendering = True - } - -commandPoolConfig :: Word32 -> Vk.CommandPoolCreateInfo '[] -commandPoolConfig gqueueIndex = - zero { Vk.queueFamilyIndex = gqueueIndex - , Vk.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT - } - -commandBufferConfig :: Vk.CommandPool -> Vk.CommandBufferAllocateInfo -commandBufferConfig gpool = - zero { Vk.commandPool = gpool - , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY - , Vk.commandBufferCount = consts.framesInFlight - } - -swapchainConfig :: QueriedData -> Vk.SurfaceKHR -> Vk.SwapchainCreateInfoKHR '[] -swapchainConfig q surface = - zero { Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR - , Vk.imageArrayLayers = 1 - , Vk.imageColorSpace = Vk.COLORSPACE_SRGB_NONLINEAR_KHR - , Vk.imageExtent = q.surfaceCapabilities.currentExtent - , Vk.imageFormat = (V.head q.surfaceFormats).format - , Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT - , Vk.minImageCount = q.surfaceCapabilities.minImageCount - , Vk.presentMode = Vk.PRESENT_MODE_FIFO_KHR - , Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR - , Vk.surface = surface - } - -imageViewConfigs :: Vector Vk.Image -> QueriedData -> Vector (Vk.ImageViewCreateInfo '[]) -imageViewConfigs images q = - V.map (\image -> (zero :: Vk.ImageViewCreateInfo '[]) { Vk.image = image - , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D - , Vk.subresourceRange = zero { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT - , Vk.levelCount = Vk.REMAINING_MIP_LEVELS - , Vk.layerCount = Vk.REMAINING_ARRAY_LAYERS - } - , Vk.format = (V.head q.surfaceFormats).format - }) images - -pipelineLayoutConfig :: Vk.PipelineLayoutCreateInfo -pipelineLayoutConfig = - zero - -graphicsPipelineConfig :: QueriedData -> Vk.ShaderModule -> Vk.ShaderModule -> Vk.PipelineLayout -> Vk.GraphicsPipelineCreateInfo '[Vk.PipelineRenderingCreateInfo] -graphicsPipelineConfig q vertMod fragMod pipelineLayout = - zero { Vk.next = (pipelineRenderingConfig q, ()) - , Vk.stages = V.map (SomeStruct) $ V.fromList [ zero { Vk.stage = Vk.SHADER_STAGE_VERTEX_BIT - , Vk.module' = vertMod - , Vk.name = "main" - } - , zero { Vk.stage = Vk.SHADER_STAGE_FRAGMENT_BIT - , Vk.module' = fragMod - , Vk.name = "main" - }] - , Vk.vertexInputState = Just zero - , Vk.inputAssemblyState = Just zero { Vk.topology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST } - , Vk.tessellationState = Nothing - , Vk.viewportState = Just $ SomeStruct zero { Vk.viewports = V.fromList [zero { Vk.x = 0 - , Vk.y = 0 - , Vk.width = fromIntegral q.surfaceCapabilities.currentExtent.width - , Vk.height = fromIntegral q.surfaceCapabilities.currentExtent.height - , Vk.minDepth = 0 - , Vk.maxDepth = 1 - }] - , Vk.scissors = V.fromList [(zero :: Vk.Rect2D) { Vk.offset = zero - , Vk.extent = q.surfaceCapabilities.currentExtent - }] - } - - , Vk.rasterizationState = Just $ SomeStruct zero { Vk.lineWidth = 1 } - , Vk.multisampleState = Just $ SomeStruct zero { Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT } - , Vk.depthStencilState = Just zero - , Vk.colorBlendState = Just $ SomeStruct zero { Vk.attachments = V.singleton zero { Vk.colorWriteMask = Vk.COLOR_COMPONENT_R_BIT .|. Vk.COLOR_COMPONENT_G_BIT .|. Vk.COLOR_COMPONENT_B_BIT .|. Vk.COLOR_COMPONENT_A_BIT }} - , Vk.dynamicState = Just zero { Vk.dynamicStates = V.fromList [Vk.DYNAMIC_STATE_VIEWPORT, Vk.DYNAMIC_STATE_SCISSOR] } - , Vk.layout = pipelineLayout - } - -pipelineRenderingConfig :: QueriedData -> Vk.PipelineRenderingCreateInfo -pipelineRenderingConfig q = - zero { Vk.colorAttachmentFormats = V.singleton (V.head q.surfaceFormats).format } - main :: IO () -main = withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_enum RGFW.RGFW_initVulkan) $ \_ -> do +main = Util.withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_enum RGFW.RGFW_initVulkan) $ \_ -> do exts <- alloca $ \extension_count -> do exts <- RGFW.rGFW_getRequiredInstanceExtensions_Vulkan extension_count cexts <- peek extension_count - vexts <- processExtensions cexts exts V.empty + vexts <- Util.processExtensions cexts exts V.empty return vexts - - Vk.withInstance (instanceConfig exts) Nothing bracket $ \i -> do - - withWindow "test window" 0 0 width height ((fromIntegral (RGFW.unwrapRGFW_windowFlags_enum RGFW.RGFW_windowCenter)) .|. (fromIntegral (RGFW.unwrapRGFW_windowFlags_enum RGFW.RGFW_windowNoResize))) $ \window -> do - + Vk.withInstance (Config.instance' exts) Nothing bracket $ \i -> do + Util.withWindow "test window" 0 0 Config.width Config.height ((fromIntegral (RGFW.unwrapRGFW_windowFlags_enum RGFW.RGFW_windowCenter)) .|. (fromIntegral (RGFW.unwrapRGFW_windowFlags_enum RGFW.RGFW_windowFloating))) $ \window -> do surface :: Vk.SurfaceKHR <- alloca $ \surfacePtr -> do _ <- RGFW.rGFW_window_createSurface_Vulkan window (coerce $ Vk.instanceHandle i) surfacePtr return . unsafeCoerce =<< peek surfacePtr (_, pdevs) <- Vk.enumeratePhysicalDevices i - (pdev, q) <- pickPhysicalDevice pdevs surface - let gqueueIndex = fromIntegral $ head $ getGraphicsQueues q - - Vk.withDevice pdev (deviceConfig gqueueIndex) Nothing bracket $ \dev -> do + (pdev, q) <- Util.pickPhysicalDevice pdevs surface + let gqueueIndex = fromIntegral $ head $ Util.getGraphicsQueues q + Vk.withDevice pdev (Config.device gqueueIndex) Nothing bracket $ \dev -> do gqueue <- Vk.getDeviceQueue dev gqueueIndex 0 - - Vk.withCommandPool dev (commandPoolConfig gqueueIndex) Nothing bracket $ \gpool -> do - Vk.withSwapchainKHR dev (swapchainConfig q surface) Nothing bracket $ \swapchain -> do - + Vk.withCommandPool dev (Config.commandPool gqueueIndex) Nothing bracket $ \gpool -> do + swapchain <- Vk.createSwapchainKHR dev (Config.swapchain q surface) Nothing (_, images) <- Vk.getSwapchainImagesKHR dev swapchain - withImageViews dev (imageViewConfigs images q) Nothing $ \imageViews -> do - - withSemaphores dev (V.fromList (take (fromIntegral consts.framesInFlight) (repeat zero))) Nothing $ \sImageAcquired -> do - withSemaphores dev (V.fromList (take (V.length images) (repeat zero))) Nothing $ \sRenderFinisheds -> do - withFences dev (V.fromList (take (fromIntegral consts.framesInFlight) (repeat ((zero :: Vk.FenceCreateInfo '[]) { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT })))) Nothing $ \fences -> do - - Vk.withCommandBuffers dev (commandBufferConfig gpool) bracket $ \cbuffers -> do - + Util.withImageViews dev (Config.imageViews images q) Nothing $ \imageViews -> do + Util.withSemaphores dev (V.fromList (take (fromIntegral Config.consts.framesInFlight) (repeat zero))) Nothing $ \sImageAcquired -> do + Util.withSemaphores dev (V.fromList (take (V.length images) (repeat zero))) Nothing $ \sRenderFinisheds -> do + Util.withFences dev (V.fromList (take (fromIntegral Config.consts.framesInFlight) (repeat ((zero :: Vk.FenceCreateInfo '[]) { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT })))) Nothing $ \fences -> do + Vk.withCommandBuffers dev (Config.commandBuffer gpool) bracket $ \cbuffers -> do rawVert <- BS.readFile Shaders.vertPath rawFrag <- BS.readFile Shaders.fragPath - withShaderModules dev (V.fromList [ zero { Vk.code = rawVert }, zero { Vk.code = rawFrag } ]) Nothing $ \mods -> do - + Util.withShaderModules dev (V.fromList [ zero { Vk.code = rawVert }, zero { Vk.code = rawFrag } ]) Nothing $ \mods -> do let vertMod = V.head mods let fragMod = V.head $ V.tail mods - Vk.withPipelineLayout dev (pipelineLayoutConfig) Nothing bracket $ \pipelineLayout -> do - - Vk.withGraphicsPipelines dev zero (V.singleton $ SomeStruct (graphicsPipelineConfig q vertMod fragMod pipelineLayout)) Nothing bracket $ \(_, pipelines) -> do - + Vk.withPipelineLayout dev (Config.pipelineLayout) Nothing bracket $ \pipelineLayout -> do + Vk.withGraphicsPipelines dev zero (V.singleton $ SomeStruct (Config.graphicsPipeline q vertMod fragMod pipelineLayout)) Nothing bracket $ \(_, pipelines) -> do let pipeline = V.head pipelines gameloop' dev q pipeline swapchain imageViews images cbuffers gqueue sImageAcquired sRenderFinisheds fences 0 window 0 - gameloop' :: Vk.Device -> QueriedData -> Vk.Pipeline -> Vk.SwapchainKHR -> Vector Vk.ImageView -> Vector Vk.Image -> Vector Vk.CommandBuffer -> Vk.Queue -> Vector Vk.Semaphore -> Vector Vk.Semaphore -> Vector Vk.Fence -> Int -> Ptr RGFW.RGFW_window -> RGFW.RGFW_bool -> IO () gameloop' dev q pipeline swapchain imageViews images cbuffers queue sImageAcquireds sRenderFinisheds fences frameIndex window 0 = do let cbuffer = (V.!) cbuffers frameIndex @@ -239,187 +81,17 @@ gameloop' dev q pipeline swapchain imageViews images cbuffers queue sImageAcquir sRenderFinished = (V.!) sRenderFinisheds $ fromIntegral imageIndex Vk.resetCommandBuffer cbuffer zero Vk.useCommandBuffer cbuffer ((zero :: Vk.CommandBufferBeginInfo '[]) { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT }) $ do - Vk.cmdPipelineBarrier2 cbuffer $ zero { Vk.imageMemoryBarriers = V.singleton $ SomeStruct zero { Vk.srcStageMask = Vk.PIPELINE_STAGE_2_NONE - , Vk.srcAccessMask = Vk.ACCESS_2_NONE - , Vk.dstStageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT - , Vk.dstAccessMask = Vk.ACCESS_2_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_2_COLOR_ATTACHMENT_WRITE_BIT - , Vk.oldLayout = Vk.IMAGE_LAYOUT_UNDEFINED - , Vk.newLayout = Vk.IMAGE_LAYOUT_ATTACHMENT_OPTIMAL - , Vk.image = image - , Vk.subresourceRange = zero { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT - , Vk.levelCount = 1 - , Vk.layerCount = 1 - } - } - } - Vk.cmdUseRendering cbuffer (zero { Vk.renderArea = zero { Vk.extent = q.surfaceCapabilities.currentExtent } - , Vk.layerCount = 1 - , Vk.colorAttachments = V.singleton $ (SomeStruct) zero { Vk.imageView = imageView - , Vk.imageLayout = Vk.IMAGE_LAYOUT_ATTACHMENT_OPTIMAL - , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR - , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE - , Vk.clearValue = Vk.Color $ Vk.Float32 0 0 1 1 - } - }) $ do - Vk.cmdSetViewport cbuffer 0 $ V.singleton zero { Vk.x = 0 - , Vk.y = 0 - , Vk.width = fromIntegral q.surfaceCapabilities.currentExtent.width - , Vk.height = fromIntegral q.surfaceCapabilities.currentExtent.height - , Vk.minDepth = 0 - , Vk.maxDepth = 1 - } - Vk.cmdSetScissor cbuffer 0 $ V.singleton zero { Vk.offset = zero - , Vk.extent = q.surfaceCapabilities.currentExtent - } + Vk.cmdPipelineBarrier2 cbuffer $ Config.preRenderPipelineBarrier image + Vk.cmdUseRendering cbuffer (Config.rendering q imageView) $ do + Vk.cmdSetViewport cbuffer 0 $ Config.viewport q + Vk.cmdSetScissor cbuffer 0 $ Config.scissor q Vk.cmdBindPipeline cbuffer Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline Vk.cmdDraw cbuffer 3 1 0 0 - Vk.cmdPipelineBarrier2 cbuffer $ zero { Vk.imageMemoryBarriers = V.singleton $ SomeStruct zero { Vk.srcStageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT - , Vk.srcAccessMask = Vk.ACCESS_2_COLOR_ATTACHMENT_WRITE_BIT - , Vk.dstStageMask = Vk.PIPELINE_STAGE_2_NONE - , Vk.dstAccessMask = Vk.ACCESS_2_NONE - , Vk.oldLayout = Vk.IMAGE_LAYOUT_ATTACHMENT_OPTIMAL - , Vk.newLayout = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR - , Vk.image = image - , Vk.subresourceRange = zero { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT - , Vk.levelCount = 1 - , Vk.layerCount = 1 - } - } - } - Vk.queueSubmit2 queue (V.singleton (SomeStruct zero { Vk.waitSemaphoreInfos = V.singleton $ zero { Vk.semaphore = sImageAcquired - , Vk.stageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT - } - , Vk.commandBufferInfos = V.singleton $ SomeStruct zero { Vk.commandBuffer = Vk.commandBufferHandle cbuffer } - , Vk.signalSemaphoreInfos = V.singleton $ zero { Vk.semaphore = sRenderFinished - , Vk.stageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT - } - })) $ V.head fence - _ <- Vk.queuePresentKHR queue (zero { Vk.waitSemaphores = V.singleton sRenderFinished - , Vk.swapchains = V.singleton swapchain - , Vk.imageIndices = V.singleton imageIndex - }) + Vk.cmdPipelineBarrier2 cbuffer $ Config.postRenderPipelineBarrier image + Vk.queueSubmit2 queue (Config.submitQueue cbuffer sImageAcquired sRenderFinished) $ V.head fence + _ <- Vk.queuePresentKHR queue (Config.present swapchain imageIndex sRenderFinished) RGFW.rGFW_pollEvents - gameloop' dev q pipeline swapchain imageViews images cbuffers queue sImageAcquireds sRenderFinisheds fences (mod (frameIndex + 1) (fromIntegral consts.framesInFlight)) window =<< RGFW.rGFW_window_shouldClose window -gameloop' dev _ _ _ _ _ _ _ _ _ _ _ _ _ = + gameloop' dev q pipeline swapchain imageViews images cbuffers queue sImageAcquireds sRenderFinisheds fences (mod (frameIndex + 1) (fromIntegral Config.consts.framesInFlight)) window =<< RGFW.rGFW_window_shouldClose window +gameloop' dev _ _ swapchain _ _ _ _ _ _ _ _ _ _ = do Vk.deviceWaitIdle dev - -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 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 + Vk.destroySwapchainKHR dev swapchain Nothing \ No newline at end of file diff --git a/Shaders.hs b/Shaders.hs deleted file mode 100644 index e86279c..0000000 --- a/Shaders.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- from the FIR docs -module Shaders where - -import FIR -import Math.Linear - -vertices = Vec3 (Vec2 0 (-0.5)) - (Vec2 0.5 0.5) - (Vec2 (-0.5) 0.5) - -vertPath = "assets/shaders/vert.spv" -fragPath = "assets/shaders/frag.spv" - -type VertexDefs = - '[ "main" ':-> EntryPoint '[] Vertex ] - -vertex :: ShaderModule "main" VertexShader VertexDefs _ -vertex = shader do - i <- get @"gl_VertexIndex" - (Vec2 x y) <- let' $ atv3v2f vertices i (Vec2 0 0) - put @"gl_Position" (Vec4 x y 0 1) - -type FragmentDefs = - '[ "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment - , "out_color" ':-> Output '[ Location 0 ] (V 4 Float) - ] - -fragment :: ShaderModule "main" FragmentShader FragmentDefs _ -fragment = shader do - put @"out_color" (Vec4 1.0 0.0 1.0 1.0) - -atv3v2f :: Code (V 3 (V 2 Float)) -> Code Word32 -> Code (V 2 Float) -> Code (V 2 Float) -atv3v2f (Vec3 x y z) i d = - if i == 0 then x - else if i == 1 then y - else if i == 2 then z - else d \ No newline at end of file diff --git a/VkTest/Config.hs b/VkTest/Config.hs new file mode 100644 index 0000000..8f18aa2 --- /dev/null +++ b/VkTest/Config.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module VkTest.Config where + +import Data.Bits ((.|.)) +import Data.ByteString (ByteString) +import Data.Int (Int32) +import Data.Vector (Vector) +import Data.Word (Word32) +import FIR (compileTo, runCompilationsTH, ModuleRequirements) +import Vulkan.CStruct.Extends (SomeStruct(..)) +import Vulkan.Zero (zero) + +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Vector as V +import qualified VkTest.Shaders as Shaders +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Core13 as Vk +import qualified Vulkan.Extensions.VK_KHR_surface as Vk +import qualified Vulkan.Extensions.VK_KHR_swapchain as Vk + +height :: Int32 +height = 400 +width :: Int32 +width = 800 + +layers :: Vector ByteString +layers = V.fromList $ map BSC.pack ["VK_LAYER_KHRONOS_validation"] + +extensions :: Vector ByteString +extensions = V.fromList $ map BSC.pack ["VK_KHR_swapchain"] + +vert :: Either a ModuleRequirements +vert = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.vertPath [] Shaders.vertex)] ) + +frag :: Either a ModuleRequirements +frag = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.fragPath [] Shaders.fragment)] ) + +data Consts = Consts + { title :: String + , vkApiVersion :: Word32 + , framesInFlight :: Word32 + } + deriving Show + +consts :: Consts +consts = + Consts + { title = "game title" + , vkApiVersion = Vk.API_VERSION_1_3 + , framesInFlight = 2 + } + +-- for a given physical device and surface +data QueriedData = QueriedData + { surfaceCapabilities :: Vk.SurfaceCapabilitiesKHR + , surfaceSupport :: [Int] + , surfaceFormats :: Vector Vk.SurfaceFormatKHR + , queueFamilyProperties :: Vector Vk.QueueFamilyProperties + , extensionProperties :: Vector Vk.ExtensionProperties + , physicalDeviceProperties :: Vk.PhysicalDeviceProperties + } + deriving Show + +instance' :: Vector ByteString -> Vk.InstanceCreateInfo '[] +instance' exts = + zero { Vk.applicationInfo = Just (zero :: Vk.ApplicationInfo) { Vk.apiVersion = consts.vkApiVersion } + , Vk.enabledExtensionNames = exts + } + +device :: Word32 -> Vk.DeviceCreateInfo '[Vk.PhysicalDeviceVulkan13Features] +device gqueueIndex = + zero { Vk.next = (vkFeatures13, ()) + , Vk.queueCreateInfos = V.singleton $ SomeStruct zero { Vk.queueFamilyIndex = gqueueIndex + , Vk.queuePriorities = V.singleton 1 + } + , Vk.enabledExtensionNames = extensions + } + +vkFeatures13 :: Vk.PhysicalDeviceVulkan13Features +vkFeatures13 = + zero { Vk.synchronization2 = True + , Vk.dynamicRendering = True + } + +commandPool :: Word32 -> Vk.CommandPoolCreateInfo '[] +commandPool gqueueIndex = + zero { Vk.queueFamilyIndex = gqueueIndex + , Vk.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT + } + +commandBuffer :: Vk.CommandPool -> Vk.CommandBufferAllocateInfo +commandBuffer gpool = + zero { Vk.commandPool = gpool + , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY + , Vk.commandBufferCount = consts.framesInFlight + } + +swapchain :: QueriedData -> Vk.SurfaceKHR -> Vk.SwapchainCreateInfoKHR '[] +swapchain q surface = + zero { Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR + , Vk.imageArrayLayers = 1 + , Vk.imageColorSpace = Vk.COLORSPACE_SRGB_NONLINEAR_KHR + , Vk.imageExtent = q.surfaceCapabilities.currentExtent + , Vk.imageFormat = (V.head q.surfaceFormats).format + , Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT + , Vk.minImageCount = q.surfaceCapabilities.minImageCount + , Vk.presentMode = Vk.PRESENT_MODE_FIFO_KHR + , Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR + , Vk.surface = surface + } + +imageViews :: Vector Vk.Image -> QueriedData -> Vector (Vk.ImageViewCreateInfo '[]) +imageViews images q = + V.map (\image -> (zero :: Vk.ImageViewCreateInfo '[]) { Vk.image = image + , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + , Vk.subresourceRange = zero { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.levelCount = Vk.REMAINING_MIP_LEVELS + , Vk.layerCount = Vk.REMAINING_ARRAY_LAYERS + } + , Vk.format = (V.head q.surfaceFormats).format + }) images + +pipelineLayout :: Vk.PipelineLayoutCreateInfo +pipelineLayout = + zero + +graphicsPipeline :: QueriedData -> Vk.ShaderModule -> Vk.ShaderModule -> Vk.PipelineLayout -> Vk.GraphicsPipelineCreateInfo '[Vk.PipelineRenderingCreateInfo] +graphicsPipeline q vertMod fragMod pipelineLayout' = + zero { Vk.next = (pipelineRendering q, ()) + , Vk.stages = V.map (SomeStruct) $ V.fromList [ zero { Vk.stage = Vk.SHADER_STAGE_VERTEX_BIT + , Vk.module' = vertMod + , Vk.name = "main" + } + , zero { Vk.stage = Vk.SHADER_STAGE_FRAGMENT_BIT + , Vk.module' = fragMod + , Vk.name = "main" + }] + , Vk.vertexInputState = Just zero + , Vk.inputAssemblyState = Just zero { Vk.topology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST } + , Vk.tessellationState = Nothing + , Vk.viewportState = Just $ SomeStruct zero { Vk.viewports = V.fromList [zero { Vk.x = 0 + , Vk.y = 0 + , Vk.width = fromIntegral q.surfaceCapabilities.currentExtent.width + , Vk.height = fromIntegral q.surfaceCapabilities.currentExtent.height + , Vk.minDepth = 0 + , Vk.maxDepth = 1 + }] + , Vk.scissors = V.fromList [(zero :: Vk.Rect2D) { Vk.offset = zero + , Vk.extent = q.surfaceCapabilities.currentExtent + }] + } + + , Vk.rasterizationState = Just $ SomeStruct zero { Vk.lineWidth = 1 } + , Vk.multisampleState = Just $ SomeStruct zero { Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT } + , Vk.depthStencilState = Just zero + , Vk.colorBlendState = Just $ SomeStruct zero { Vk.attachments = V.singleton zero { Vk.colorWriteMask = Vk.COLOR_COMPONENT_R_BIT .|. Vk.COLOR_COMPONENT_G_BIT .|. Vk.COLOR_COMPONENT_B_BIT .|. Vk.COLOR_COMPONENT_A_BIT }} + , Vk.dynamicState = Just zero { Vk.dynamicStates = V.fromList [Vk.DYNAMIC_STATE_VIEWPORT, Vk.DYNAMIC_STATE_SCISSOR] } + , Vk.layout = pipelineLayout' + } + +pipelineRendering :: QueriedData -> Vk.PipelineRenderingCreateInfo +pipelineRendering q = + zero { Vk.colorAttachmentFormats = V.singleton (V.head q.surfaceFormats).format } + +preRenderPipelineBarrier :: Vk.Image -> Vk.DependencyInfo '[] +preRenderPipelineBarrier image = + zero { Vk.imageMemoryBarriers = V.singleton $ SomeStruct zero { Vk.srcStageMask = Vk.PIPELINE_STAGE_2_NONE + , Vk.srcAccessMask = Vk.ACCESS_2_NONE + , Vk.dstStageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.dstAccessMask = Vk.ACCESS_2_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_2_COLOR_ATTACHMENT_WRITE_BIT + , Vk.oldLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.newLayout = Vk.IMAGE_LAYOUT_ATTACHMENT_OPTIMAL + , Vk.image = image + , Vk.subresourceRange = zero { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.levelCount = 1 + , Vk.layerCount = 1 + } + } + } + +postRenderPipelineBarrier :: Vk.Image -> Vk.DependencyInfo '[] +postRenderPipelineBarrier image = + zero { Vk.imageMemoryBarriers = V.singleton $ SomeStruct zero { Vk.srcStageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.srcAccessMask = Vk.ACCESS_2_COLOR_ATTACHMENT_WRITE_BIT + , Vk.dstStageMask = Vk.PIPELINE_STAGE_2_NONE + , Vk.dstAccessMask = Vk.ACCESS_2_NONE + , Vk.oldLayout = Vk.IMAGE_LAYOUT_ATTACHMENT_OPTIMAL + , Vk.newLayout = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR + , Vk.image = image + , Vk.subresourceRange = zero { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.levelCount = 1 + , Vk.layerCount = 1 + } + } + } + +rendering :: QueriedData -> Vk.ImageView -> Vk.RenderingInfo '[] +rendering q imageView = + zero { Vk.renderArea = zero { Vk.extent = q.surfaceCapabilities.currentExtent } + , Vk.layerCount = 1 + , Vk.colorAttachments = V.singleton $ (SomeStruct) zero { Vk.imageView = imageView + , Vk.imageLayout = Vk.IMAGE_LAYOUT_ATTACHMENT_OPTIMAL + , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR + , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE + , Vk.clearValue = Vk.Color $ Vk.Float32 0 0 1 1 + } + } + +viewport :: QueriedData -> Vector Vk.Viewport +viewport q = + V.singleton zero { Vk.x = 0 + , Vk.y = 0 + , Vk.width = fromIntegral q.surfaceCapabilities.currentExtent.width + , Vk.height = fromIntegral q.surfaceCapabilities.currentExtent.height + , Vk.minDepth = 0 + , Vk.maxDepth = 1 + } + +scissor :: QueriedData -> Vector Vk.Rect2D +scissor q = + V.singleton (zero :: Vk.Rect2D) { Vk.offset = zero + , Vk.extent = q.surfaceCapabilities.currentExtent + } + +submitQueue :: Vk.CommandBuffer -> Vk.Semaphore -> Vk.Semaphore -> Vector (SomeStruct Vk.SubmitInfo2) +submitQueue cbuffer sImageAcquired sRenderFinished = + V.singleton $ SomeStruct zero { Vk.waitSemaphoreInfos = V.singleton $ zero { Vk.semaphore = sImageAcquired + , Vk.stageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT + } + , Vk.commandBufferInfos = V.singleton $ SomeStruct zero { Vk.commandBuffer = Vk.commandBufferHandle cbuffer } + , Vk.signalSemaphoreInfos = V.singleton $ zero { Vk.semaphore = sRenderFinished + , Vk.stageMask = Vk.PIPELINE_STAGE_2_COLOR_ATTACHMENT_OUTPUT_BIT + } + } + +present :: Vk.SwapchainKHR -> Word32 -> Vk.Semaphore -> Vk.PresentInfoKHR '[] +present swapchain' imageIndex sRenderFinished = + zero { Vk.waitSemaphores = V.singleton sRenderFinished + , Vk.swapchains = V.singleton swapchain' + , Vk.imageIndices = V.singleton imageIndex + } \ No newline at end of file diff --git a/VkTest/Shaders.hs b/VkTest/Shaders.hs new file mode 100644 index 0000000..0d88325 --- /dev/null +++ b/VkTest/Shaders.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module VkTest.Shaders where + +import FIR +import Math.Linear + +vertices = Vec3 (Vec2 0 (-0.5)) + (Vec2 0.5 0.5) + (Vec2 (-0.5) 0.5) + +vertPath = "assets/shaders/vert.spv" +fragPath = "assets/shaders/frag.spv" + +type VertexDefs = + '[ "main" ':-> EntryPoint '[] Vertex ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + i <- get @"gl_VertexIndex" + (Vec2 x y) <- let' $ atv3v2f vertices i (Vec2 0 0) + put @"gl_Position" (Vec4 x y 0 1) + +type FragmentDefs = + '[ "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + , "out_color" ':-> Output '[ Location 0 ] (V 4 Float) + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out_color" (Vec4 1.0 0.0 1.0 1.0) + +atv3v2f :: Code (V 3 (V 2 Float)) -> Code Word32 -> Code (V 2 Float) -> Code (V 2 Float) +atv3v2f (Vec3 x y z) i d = + if i == 0 then x + else if i == 1 then y + else if i == 2 then z + else d \ No newline at end of file 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 diff --git a/vktest.cabal b/vktest.cabal index 12525a3..3968074 100644 --- a/vktest.cabal +++ b/vktest.cabal @@ -11,8 +11,10 @@ extra-doc-files: CHANGELOG.md executable vktest main-is: Main.hs - other-modules: RGFW, - Shaders, + other-modules: VkTest.Shaders, + VkTest.Config, + VkTest.Util, + RGFW, build-depends: base >= 4.20.2, bytestring >= 0.12, vector >= 0.13, @@ -30,5 +32,5 @@ executable vktest include-dirs: include hs-source-dirs: . c-sources: shim.c - ghc-options: -Wall -optc-DRGFW_VULKAN + ghc-options: -Wall -Wno-ambiguous-fields -optc-DRGFW_VULKAN default-language: Haskell2010 \ No newline at end of file -- cgit v1.3.1