diff options
| -rw-r--r-- | Main.hs | 228 | ||||
| -rw-r--r-- | Shaders.hs | 41 | ||||
| -rw-r--r-- | vktest.cabal | 2 |
3 files changed, 211 insertions, 60 deletions
@@ -14,15 +14,13 @@ import Data.Coerce (coerce) import Data.Int (Int32) import Data.List ((\\)) import Data.Vector (Vector) -import FIR (compileTo, runCompilationsTH) +import FIR (compileTo, runCompilationsTH, CompilerFlag(SPIRV), Version(..)) 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 Language.Haskell.TH (runIO) -import System.Directory (makeAbsolute) import Unsafe.Coerce (unsafeCoerce) import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Zero (zero) @@ -47,9 +45,8 @@ layers = V.fromList $ map BSC.pack ["VK_LAYER_KHRONOS_validation"] extensions :: Vector ByteString extensions = V.fromList $ map BSC.pack ["VK_KHR_swapchain"] -frag = $(do - fragPath <- runIO $ makeAbsolute "assets/shaders/frag.spv" - runCompilationsTH [("Fragment Shader", compileTo fragPath [] Shaders.fragment)] ) +vert = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.vertPath [SPIRV (Version 1 0)] Shaders.vertex)] ) +frag = $( runCompilationsTH [("Fragment Shader", compileTo Shaders.fragPath [SPIRV (Version 1 0)] Shaders.fragment)] ) main :: IO () main = withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_enum RGFW.RGFW_initVulkan) $ \_ -> do @@ -58,7 +55,10 @@ main = withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_ cexts <- peek extension_count vexts <- processExtensions cexts exts V.empty return vexts - Vk.withInstance (zero {Vk.enabledExtensionNames = exts, Vk.enabledLayerNames = layers}) Nothing bracket $ \i -> do + Vk.withInstance (zero { Vk.applicationInfo = Just (zero :: Vk.ApplicationInfo) { Vk.apiVersion = Vk.API_VERSION_1_0 } + , Vk.enabledExtensionNames = exts + , Vk.enabledLayerNames = layers + }) 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 surface :: Vk.SurfaceKHR <- alloca $ \surfacePtr -> do _ <- RGFW.rGFW_window_createSurface_Vulkan window (coerce $ Vk.instanceHandle i) surfacePtr @@ -66,7 +66,7 @@ main = withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_ (_, pdevs) <- Vk.enumeratePhysicalDevices i pdev <- pickPhysicalDevice pdevs surface qfprops <- Vk.getPhysicalDeviceQueueFamilyProperties pdev - gqueueIndex <- return $ fromIntegral $ head $ getGraphicsQueues qfprops + let gqueueIndex = fromIntegral $ head $ getGraphicsQueues qfprops pqueueIndex <- return . fromIntegral . head =<< getSurfaceSupport pdev surface queueCreateInfos <- return $ [(zero :: Vk.DeviceQueueCreateInfo '[]) { Vk.queueFamilyIndex = gqueueIndex, Vk.queuePriorities = V.fromList [1.0]}] ++ if gqueueIndex == pqueueIndex then [] else [(zero :: Vk.DeviceQueueCreateInfo '[]) { Vk.queueFamilyIndex = pqueueIndex, Vk.queuePriorities = V.fromList [1.0]}] @@ -76,7 +76,8 @@ main = withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_ gqueue <- Vk.getDeviceQueue dev gqueueIndex 0 pqueue <- Vk.getDeviceQueue dev pqueueIndex 0 Vk.withCommandPool dev (zero {Vk.queueFamilyIndex = gqueueIndex, Vk.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT}) Nothing bracket $ \gpool -> do - Vk.withCommandBuffers dev (zero {Vk.commandPool = gpool, Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY, Vk.commandBufferCount = 2}) bracket $ \gcbuffer -> do + Vk.withCommandBuffers dev (zero {Vk.commandPool = gpool, Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY, Vk.commandBufferCount = 1}) bracket $ \gcbuffers -> do + let gcbuffer = V.head gcbuffers putStrLn "made command buffer" caps <- Vk.getPhysicalDeviceSurfaceCapabilitiesKHR pdev surface putStrLn $ show caps @@ -105,18 +106,128 @@ main = withRGFW "rgfw instance title" (fromIntegral $ RGFW.unwrapRGFW_initFlags_ } , Vk.format = (V.head forms).format -- TODO fetch the best format }) images) Nothing $ \imageViews -> do - Vk.withRenderPass dev zero { Vk.subpasses = V.fromList [zero {Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS}] + let colorAttachmentRef = zero { Vk.attachment = 0 + , Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + } + let colorAttachment = zero { Vk.format = (V.head forms).format -- TODO fetch the best format + , Vk.samples = Vk.SAMPLE_COUNT_1_BIT + , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR + , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE + , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE + , Vk.stencilStoreOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.finalLayout = Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR + } + Vk.withRenderPass dev zero { Vk.attachments = V.singleton colorAttachment + , Vk.subpasses = V.singleton zero { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS + , Vk.colorAttachments = V.singleton colorAttachmentRef + } + , Vk.dependencies = V.singleton zero { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL + , Vk.dstSubpass = 0 + , Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.srcAccessMask = Vk.ACCESS_NONE + , Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.dstAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } } Nothing bracket $ \pass -> do putStrLn "made pass" - Vk.withFramebuffer dev zero { Vk.height = fromIntegral height - , Vk.width = fromIntegral width - , Vk.renderPass = pass - , Vk.layers = 1 - } Nothing bracket $ \fb -> do + let fb = zero { Vk.height = fromIntegral height + , Vk.width = fromIntegral width + , Vk.renderPass = pass + , Vk.attachments = V.singleton $ V.head imageViews + , Vk.layers = 1 + } + let infos = V.map (\image -> (fb :: Vk.FramebufferCreateInfo '[]) { Vk.attachments = V.singleton image }) imageViews + withFramebuffers dev infos Nothing $ \fbs -> do putStrLn "made fb" - ret <- gameloop window 0 - putStr "gameloop returned with code: " - putStrLn $ show ret + 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 + let vertMod = V.head mods + let fragMod = V.head $ V.tail mods + Vk.withPipelineLayout dev zero Nothing bracket $ \pipelineLayout -> do + print pipelineLayout + Vk.withGraphicsPipelines dev zero (V.map (SomeStruct) $ V.fromList [zero { 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 = Just zero + , Vk.viewportState = Just $ SomeStruct zero { Vk.viewports = V.fromList [zero { Vk.x = 0 + , Vk.y = 0 + , Vk.width = fromIntegral width + , Vk.height = fromIntegral height + , Vk.minDepth = 0 + , Vk.maxDepth = 1 + }] + , Vk.scissors = V.fromList [(zero :: Vk.Rect2D) { Vk.offset = zero + , Vk.extent = zero { Vk.width = fromIntegral width + , Vk.height = fromIntegral height + } + }] + } + , Vk.rasterizationState = Just $ SomeStruct zero { Vk.depthClampEnable = False + , Vk.rasterizerDiscardEnable = False + , Vk.polygonMode = Vk.POLYGON_MODE_FILL + , Vk.cullMode = Vk.CULL_MODE_BACK_BIT + , Vk.frontFace = Vk.FRONT_FACE_CLOCKWISE + , Vk.depthBiasEnable = False + , Vk.lineWidth = 1 + } + , Vk.multisampleState = Just $ SomeStruct zero { Vk.sampleShadingEnable = False + , Vk.rasterizationSamples = Vk.SAMPLE_COUNT_1_BIT + } + , Vk.depthStencilState = Nothing + , Vk.colorBlendState = Just $ SomeStruct zero { Vk.attachments = V.singleton zero { Vk.blendEnable = False }} + , Vk.layout = pipelineLayout + , Vk.renderPass = pass + , Vk.subpass = 0 + }]) Nothing bracket $ \(_, pipelines) -> do + print pipelines + let pipeline = V.head pipelines + Vk.withSemaphore dev zero Nothing bracket $ \sImageAvailable -> do + withSemaphores dev (V.fromList (take (V.length imageViews) (repeat zero))) Nothing $ \sRenderFinisheds -> do + Vk.withFence dev (zero { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT }) Nothing bracket $ \fInFlight -> do + ret <- gameloop dev swapchain gcbuffer gqueue pqueue fbs pass pipeline window (V.cons sImageAvailable sRenderFinisheds) fInFlight 0 + putStr "gameloop returned" + +gameloop :: Vk.Device -> Vk.SwapchainKHR -> Vk.CommandBuffer -> Vk.Queue -> Vk.Queue -> Vector Vk.Framebuffer -> Vk.RenderPass -> Vk.Pipeline -> Ptr RGFW.RGFW_window -> Vector Vk.Semaphore -> Vk.Fence -> RGFW.RGFW_bool -> IO () +gameloop dev swapchain gcbuffer gqueue pqueue fbs pass pipeline window ss f 0 = do + let fs = V.singleton f + let sImageAvailable = V.head ss + let sRenderFinisheds = V.tail ss + Vk.waitForFences dev fs True 18446744073709551615 + Vk.resetFences dev fs + (_, imageIndex) <- Vk.acquireNextImageKHR dev swapchain 18446744073709551615 sImageAvailable zero + Vk.resetCommandBuffer gcbuffer zero + Vk.useCommandBuffer gcbuffer zero $ do + Vk.cmdUseRenderPass gcbuffer (zero { Vk.renderPass = pass + , Vk.framebuffer = (V.!) fbs $ fromIntegral imageIndex + , Vk.renderArea = (zero :: Vk.Rect2D) { Vk.offset = zero + , Vk.extent = zero { Vk.width = fromIntegral width + , Vk.height = fromIntegral height + } + } + , Vk.clearValues = V.singleton zero + }) Vk.SUBPASS_CONTENTS_INLINE $ do + Vk.cmdBindPipeline gcbuffer Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline + Vk.cmdDraw gcbuffer 3 1 0 0 + Vk.queueSubmit gqueue (V.singleton (SomeStruct zero { Vk.waitSemaphores = V.singleton sImageAvailable + , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.commandBuffers = V.singleton $ Vk.commandBufferHandle gcbuffer + , Vk.signalSemaphores = V.singleton $ (V.!) sRenderFinisheds (fromIntegral imageIndex) + })) f + Vk.queuePresentKHR pqueue (zero { Vk.waitSemaphores = V.singleton $ (V.!) sRenderFinisheds (fromIntegral imageIndex) + , Vk.swapchains = V.singleton swapchain + , Vk.imageIndices = V.singleton imageIndex + }) + gameloop dev swapchain gcbuffer gqueue pqueue fbs pass pipeline window ss f =<< RGFW.rGFW_window_shouldClose window +gameloop _ _ _ _ _ _ _ _ _ _ _ _ = return () pickPhysicalDevice :: Vector Vk.PhysicalDevice -> Vk.SurfaceKHR -> IO Vk.PhysicalDevice pickPhysicalDevice pdevs surface = do @@ -124,28 +235,30 @@ pickPhysicalDevice pdevs surface = do pickPhysicalDevice' validpdevs V.empty pickPhysicalDevice' :: Vector Vk.PhysicalDevice -> Vector Vk.PhysicalDevice -> IO Vk.PhysicalDevice -pickPhysicalDevice' pdevs opts = if V.null pdevs - then do - props <- Vk.getPhysicalDeviceProperties $ V.head opts - putStr "Selected physical device of type: " - putStrLn $ show props.deviceType - return $ V.head opts - else do - props <- Vk.getPhysicalDeviceProperties $ V.head pdevs - case props.deviceType of - Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU -> pickPhysicalDevice' (V.tail pdevs) (V.cons (V.head pdevs) opts) - Vk.PHYSICAL_DEVICE_TYPE_CPU -> pickPhysicalDevice' (V.tail pdevs) opts - _ -> pickPhysicalDevice' (V.tail pdevs) (V.snoc opts (V.head pdevs)) +pickPhysicalDevice' pdevs opts = + if V.null pdevs + then do + props <- Vk.getPhysicalDeviceProperties $ V.head opts + putStr "Selected physical device of type: " + putStrLn $ show props.deviceType + return $ V.head opts + else do + props <- Vk.getPhysicalDeviceProperties $ V.head pdevs + case props.deviceType of + Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU -> pickPhysicalDevice' (V.tail pdevs) (V.cons (V.head pdevs) opts) + Vk.PHYSICAL_DEVICE_TYPE_CPU -> pickPhysicalDevice' (V.tail pdevs) opts + _ -> pickPhysicalDevice' (V.tail pdevs) (V.snoc opts (V.head pdevs)) -- returns list of queueFamilyIndex whick support a graphics pipeline getGraphicsQueues :: Vector Vk.QueueFamilyProperties -> [Int] getGraphicsQueues qfprops = getGraphicsQueues' qfprops 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 +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] @@ -182,27 +295,46 @@ processExtensions count strs extNames = do extName <- BS.packCString (coerce str) processExtensions (count - 1) (advancePtr strs 1) $ V.snoc extNames extName -gameloop :: Ptr RGFW.RGFW_window -> RGFW.RGFW_bool -> IO () -gameloop window 0 = gameloop window =<< RGFW.rGFW_window_shouldClose window -gameloop _ _ = return () +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 + +withFramebuffers :: Vk.Device -> Vector (Vk.FramebufferCreateInfo '[]) -> Maybe Vk.AllocationCallbacks -> (Vector Vk.Framebuffer -> IO r) -> IO r +withFramebuffers dev infos alloc io = do + fbs <- mapM (\info -> Vk.createFramebuffer dev info alloc) infos + o0 <- io fbs + _ <- mapM (\fb -> Vk.destroyFramebuffer dev fb alloc) fbs + 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 + 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 +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 +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 @@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -10,14 +11,34 @@ module Shaders where import FIR import Math.Linear -type FragmentDefs = '[ "in_pos" ':-> Input '[ Location 0 ] (V 2 Float) - , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) - , "image" ':-> Texture2D '[ DescriptorSet 0, Binding 0 ] (RGBA8 UNorm) - , "main" ':-> EntryPoint '[ OriginLowerLeft ] Fragment - ] +vertices = Vec3 (Vec2 0 (-0.5)) + (Vec2 0.5 0.5) + (Vec2 (-0.5) 0.5) -fragment :: Module FragmentDefs -fragment = Module $ entryPoint @"main" @Fragment do - pos <- get @"in_pos" - col <- use @(ImageTexel "image") NilOps pos - put @"out_col" col
\ No newline at end of file +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" + let (Vec2 x y) = atv3v2f vertices i (Vec2 0 0) + put @"gl_Position" (Vec4 x y 0.0 1.0) + +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 1.0 0.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.cabal b/vktest.cabal index af2476e..12525a3 100644 --- a/vktest.cabal +++ b/vktest.cabal @@ -15,8 +15,6 @@ executable vktest Shaders, build-depends: base >= 4.20.2, bytestring >= 0.12, - directory >= 1.3, - template-haskell >= 2.24, vector >= 0.13, vulkan >= 3.27, hs-bindgen, |