From 4c09e5d5a63bd8cf9b529ed826b2c8b3a2f30212 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 16 Jul 2022 21:50:22 +0200 Subject: [PATCH] a little cleanup --- src/CommandBuffer.hs | 2 +- src/Draw.hs | 122 ++++++++++++++++----------------- src/GraphicsPipeline.hs | 145 +++++++++++++++++++++++----------------- src/Init.hs | 73 +++++++------------- src/Main.hs | 20 ++---- vulkan-tutorial.cabal | 1 + 6 files changed, 171 insertions(+), 192 deletions(-) diff --git a/src/CommandBuffer.hs b/src/CommandBuffer.hs index 69b96e2..106ab8a 100644 --- a/src/CommandBuffer.hs +++ b/src/CommandBuffer.hs @@ -34,7 +34,7 @@ createCommandPool physicalDevice logicalDevice = do commandPool <- snd <$> allocate (Vk.createCommandPool logicalDevice poolCreateInfo Nothing) (\commandPool -> do - putStrLn "destroying comman pool" + putStrLn "destroying command pool" Vk.destroyCommandPool logicalDevice commandPool Nothing ) diff --git a/src/Draw.hs b/src/Draw.hs index ed27d49..cbf12a6 100644 --- a/src/Draw.hs +++ b/src/Draw.hs @@ -6,8 +6,6 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource import qualified Data.Vector as V -import Foreign.C.Types (CInt) -import Linear (V2(..)) import qualified Vulkan.Core10 as Vk import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr import qualified Vulkan.CStruct.Extends as Vk @@ -16,81 +14,77 @@ import qualified Vulkan.Zero as Vk -- internal imports import CommandBuffer +import Types drawFrame :: (MonadResource m) - => Vk.Device - -> Khr.SwapchainKHR - -> Vk.Queue - -> V.Vector Vk.CommandBuffer - -> Vk.RenderPass - -> V.Vector Vk.Framebuffer - -> V2 CInt - -> V.Vector Vk.Pipeline - -> Vk.Fence - -> Vk.Semaphore - -> Vk.Semaphore + => EngineData -> m () -drawFrame - logicalDevice - swapchain - graphicsQueue - commandBuffers - renderPass - framebuffers - dimensions - pipelines - inFlightFence - imageAvailableSemaphore - renderFinishedSemaphore - = do +drawFrame engineData = do - unless (all (V.length commandBuffers ==) - [V.length commandBuffers, V.length framebuffers, V.length pipelines]) $ - error ("Numbers of elements mismatch: command buffers " <> show (V.length commandBuffers) <> - ", frame buffers " <> show (V.length framebuffers) <> - ", pipelines " <> show (V.length pipelines)) + unless (all (V.length (engineCommandBuffers engineData) ==) + [ V.length (engineCommandBuffers engineData) + , V.length (engineFramebuffers engineData) + , V.length (enginePipelines engineData) + ]) $ + error ("Numbers of elements mismatch: command buffers " <> + show (V.length $ engineCommandBuffers engineData) <> + ", frame buffers " <> show (V.length $ engineFramebuffers engineData) <> + ", pipelines " <> show (V.length $ enginePipelines engineData)) - let fences = V.singleton inFlightFence + let fences = V.singleton $ engineInFlightFence engineData - void $ Vk.waitForFences logicalDevice fences True maxBound - Vk.resetFences logicalDevice fences + void $ Vk.waitForFences (engineLogicalDevice engineData) fences True maxBound + Vk.resetFences (engineLogicalDevice engineData) fences - (imageResult, index) <- - Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE + (imageResult, index) <- + Khr.acquireNextImageKHR + (engineLogicalDevice engineData) + (engineSwapchain engineData) + maxBound + (engineImageAvailableSemaphore engineData) + Vk.NULL_HANDLE - unless (imageResult == Vk.SUCCESS) $ - error "drawFrame: Failed acquiring next image from swapchain" + unless (imageResult == Vk.SUCCESS) $ + error "drawFrame: Failed acquiring next image from swapchain" - liftIO $ putStrLn "resetting command buffer" - Vk.resetCommandBuffer (commandBuffers V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0) + -- liftIO $ putStrLn "resetting command buffer" + Vk.resetCommandBuffer + (engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0) - liftIO $ putStrLn "recording command buffer" - recordCommandBuffer - (commandBuffers V.! fromIntegral index) - renderPass - (framebuffers V.! fromIntegral index) - dimensions - (pipelines V.! fromIntegral index) + -- liftIO $ putStrLn "recording command buffer" + recordCommandBuffer + (engineCommandBuffers engineData V.! fromIntegral index) + (engineRenderPass engineData) + (engineFramebuffers engineData V.! fromIntegral index) + (engineWindowDimensions engineData) + (enginePipelines engineData V.! fromIntegral index) - let submitInfo = Vk.zero - { Vk.waitSemaphores = V.singleton imageAvailableSemaphore - , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , Vk.commandBuffers = V.singleton (Vk.commandBufferHandle $ commandBuffers V.! fromIntegral index) - , Vk.signalSemaphores = V.singleton renderFinishedSemaphore - } + let submitInfo = Vk.zero + { Vk.waitSemaphores = + V.singleton $ engineImageAvailableSemaphore engineData + , Vk.waitDstStageMask = + V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.commandBuffers = + V.singleton (Vk.commandBufferHandle $ engineCommandBuffers engineData V.! fromIntegral index) + , Vk.signalSemaphores = + V.singleton $ engineRenderFinishedSemaphore engineData + } - liftIO $ putStrLn "submitting to queue" - Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence + -- liftIO $ putStrLn "submitting to queue" + Vk.queueSubmit + (engineQueue engineData) + (V.singleton (Vk.SomeStruct submitInfo)) + (engineInFlightFence engineData) - let presentInfo = Vk.zero - { Khr.waitSemaphores = V.singleton renderFinishedSemaphore - , Khr.swapchains = V.singleton swapchain - , Khr.imageIndices = V.singleton index - } + let presentInfo = Vk.zero + { Khr.waitSemaphores = V.singleton $ engineRenderFinishedSemaphore engineData + , Khr.swapchains = V.singleton $ engineSwapchain engineData + , Khr.imageIndices = V.singleton index + } - liftIO $ putStrLn "presenting queue" - presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo + -- liftIO $ putStrLn "presenting queue" + presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo - unless (presentResult == Vk.SUCCESS) $ - error "drawFrame: presentation failed" + unless (presentResult == Vk.SUCCESS) $ + error "drawFrame: presentation failed" diff --git a/src/GraphicsPipeline.hs b/src/GraphicsPipeline.hs index 9b9870e..13f94a9 100644 --- a/src/GraphicsPipeline.hs +++ b/src/GraphicsPipeline.hs @@ -17,6 +17,9 @@ import qualified Vulkan.Zero as Vk import qualified Vulkan.CStruct.Extends as Vk import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk +-- internal imports +import Types + loadShader :: (MonadResource m) => Vk.Device @@ -49,34 +52,86 @@ loadShader logicalDevice shaderPath stage = do Vk.destroyShaderModule logicalDevice shaderModule Nothing ) +createRenderPass + :: (MonadResource m) + => Vk.Device + -> Vk.Format + -> m Vk.RenderPass +createRenderPass + logicalDevice + swapchainImageFormat + = do + + + + let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription) + { Vk.format = swapchainImageFormat + , 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 + } + colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference) + { Vk.attachment = 0 + , Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + } + subpassDescriptor = (Vk.zero :: Vk.SubpassDescription) + { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS + , Vk.colorAttachments = V.singleton colorAttachmentReference + } + subpassDependency = Vk.zero + { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL + , Vk.dstSubpass = 0 + , Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + , Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + , Vk.dstAccessMask = + Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } + renderPassCreateInfo = Vk.zero + { Vk.attachments = V.singleton colorAttachmentDescription + , Vk.subpasses = V.singleton subpassDescriptor + , Vk.dependencies = V.singleton subpassDependency + } :: Vk.RenderPassCreateInfo '[] + + snd <$> allocate + (Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing) + (\renderPass -> do + putStrLn "destroying render pass" + Vk.destroyRenderPass logicalDevice renderPass Nothing + ) + + createGraphicsPipelines :: (MonadResource m) => Vk.Device - -> Vk.ShaderModule - -> Vk.ShaderModule + -> Vk.RenderPass + -> ShaderContainer -> BS.ByteString -> V2 CInt - -> Vk.Format -> Int - -> m (V.Vector Vk.Pipeline, Vk.RenderPass) + -> Vk.PipelineLayout + -> m (V.Vector Vk.Pipeline) createGraphicsPipelines logicalDevice - vertexShaderModule - fragmentShaderModule + renderPass + shaderContainer stageName (V2 width height) - swapchainImageFormat number + pipelineLayout = do - let vertexShaderStageCreateInfo = Vk.zero { Vk.stage = Vk.SHADER_STAGE_VERTEX_BIT - , Vk.module' = vertexShaderModule + , Vk.module' = containedVertexShader shaderContainer , Vk.name = stageName } fragmentShaderStageCreateInfo = Vk.zero { Vk.stage = Vk.SHADER_STAGE_FRAGMENT_BIT - , Vk.module' = fragmentShaderModule + , Vk.module' = containedFragmentShader shaderContainer , Vk.name = stageName } pipelineStagesCreateInfos = @@ -150,56 +205,7 @@ createGraphicsPipelines { Vk.logicOpEnable = False , Vk.attachments = V.singleton colorBlendAttachment } - pipelineLayoutCreateInfo = Vk.zero - - pipelineLayout <- snd <$> allocate - (Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing) - (\pipelineLayout -> do - putStrLn "destroying pipeline layout" - Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing - ) - - let colorAttachmentDescription = (Vk.zero :: Vk.AttachmentDescription) - { Vk.format = swapchainImageFormat - , 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 - } - colorAttachmentReference = (Vk.zero :: Vk.AttachmentReference) - { Vk.attachment = 0 - , Vk.layout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL - } - subpassDescriptor = (Vk.zero :: Vk.SubpassDescription) - { Vk.pipelineBindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS - , Vk.colorAttachments = V.singleton colorAttachmentReference - } - subpassDependency = Vk.zero - { Vk.srcSubpass = Vk.SUBPASS_EXTERNAL - , Vk.dstSubpass = 0 - , Vk.srcStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , Vk.dstStageMask = Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT - , Vk.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT - , Vk.dstAccessMask = - Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT - } - renderPassCreateInfo = Vk.zero - { Vk.attachments = V.singleton colorAttachmentDescription - , Vk.subpasses = V.singleton subpassDescriptor - , Vk.dependencies = V.singleton subpassDependency - } :: Vk.RenderPassCreateInfo '[] - - pipelineRenderPass <- snd <$> allocate - (Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing) - (\renderPass -> do - putStrLn "destroying render pass" - Vk.destroyRenderPass logicalDevice renderPass Nothing - ) - - let pipelineCreateInfo = Vk.zero + pipelineCreateInfo = Vk.zero { Vk.stageCount = 2 , Vk.stages = pipelineStagesCreateInfos , Vk.vertexInputState = Just $ Vk.SomeStruct pipelineVertexInputCreateInfo @@ -210,13 +216,13 @@ createGraphicsPipelines , Vk.colorBlendState = Just $ Vk.SomeStruct pipelineColorBlendStateCreateInfo , Vk.dynamicState = Just pipelineDynamicStateCreateInfo , Vk.layout = pipelineLayout - , Vk.renderPass = pipelineRenderPass + , Vk.renderPass = renderPass , Vk.subpass = 0 , Vk.basePipelineHandle = Vk.NULL_HANDLE , Vk.basePipelineIndex = -1 } - pipelines <- snd <$> allocate + snd <$> allocate (do (result, pipelines) <- Vk.createGraphicsPipelines logicalDevice @@ -235,4 +241,17 @@ createGraphicsPipelines ) pipelines ) - return (pipelines, pipelineRenderPass) + +createPipelineLayout + :: MonadResource m + => Vk.Device + -> m Vk.PipelineLayout +createPipelineLayout logicalDevice = do + let pipelineLayoutCreateInfo = Vk.zero + + snd <$> allocate + (Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing) + (\pipelineLayout -> do + putStrLn "destroying pipeline layout" + Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing + ) diff --git a/src/Init.hs b/src/Init.hs index 4fcf639..b7b3e47 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -6,11 +6,8 @@ module Init where import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource -import qualified Data.Vector as V -import Linear (V2) import qualified SDL hiding (V2) import qualified SDL.Video.Vulkan as SDL -import Foreign.C.Types (CInt) import Foreign.Ptr import qualified Vulkan.Core10 as Vk import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr @@ -23,23 +20,11 @@ import Devices import GraphicsPipeline import Framebuffers import CommandBuffer +import Types initEngine :: (MonadResource m, MonadFail m) - => m - ( SDL.Window - , V2 CInt - , Vk.Device - , Khr.SwapchainKHR - , Vk.Queue - , V.Vector Vk.CommandBuffer - , V.Vector Vk.Framebuffer - , V.Vector Vk.Pipeline - , Vk.RenderPass - , Vk.Fence - , Vk.Semaphore - , Vk.Semaphore - ) + => m EngineData initEngine = do -- initialize SDL2 with all subsystems void $ allocate_ @@ -72,20 +57,7 @@ initEngine = do initVulkan :: (MonadResource m, MonadFail m) => SDL.Window - -> m - ( SDL.Window - , V2 CInt - , Vk.Device - , Khr.SwapchainKHR - , Vk.Queue - , V.Vector Vk.CommandBuffer - , V.Vector Vk.Framebuffer - , V.Vector Vk.Pipeline - , Vk.RenderPass - , Vk.Fence - , Vk.Semaphore - , Vk.Semaphore - ) + -> m EngineData initVulkan window = do vulkanInstance <- createInstance window @@ -108,15 +80,18 @@ initVulkan window = do imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert" fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag" - (pipelines, renderPass) <- + renderPass <- createRenderPass vulkanLogicalDevice (Khr.format surfaceFormat) + pipelineLayout <- createPipelineLayout vulkanLogicalDevice + let shaderContainer = ShaderContainer vertexShader fragmentShader + pipelines <- createGraphicsPipelines vulkanLogicalDevice - vertexShader - fragmentShader + renderPass + shaderContainer "main" dimensions - (Khr.format surfaceFormat) (length imageViews) + pipelineLayout frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions @@ -126,17 +101,17 @@ initVulkan window = do (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <- createSyncObjects vulkanLogicalDevice - return - ( window - , dimensions - , vulkanLogicalDevice - , swapchain - , graphicsQueue - , commandBuffer - , frameBuffers - , pipelines - , renderPass - , inFlightFence - , imageAvailableSemaphore - , renderFinishedSemaphore - ) + return $ EngineData + window + dimensions + vulkanLogicalDevice + swapchain + graphicsQueue + commandBuffer + frameBuffers + pipelines + renderPass + inFlightFence + imageAvailableSemaphore + renderFinishedSemaphore + diff --git a/src/Main.hs b/src/Main.hs index 69465c5..8db98ee 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,12 +19,13 @@ import qualified Vulkan.Zero as Vk import Init import Draw (drawFrame) +import Types main :: IO () main = runResourceT $ do - (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffers, framebuffers, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine + engineData <- initEngine - SDL.showWindow window + SDL.showWindow $ engineWindow engineData -- create abort condition for upcoming lop quit <- liftIO $ STM.newTMVarIO True @@ -35,18 +36,7 @@ main = runResourceT $ do ) ( do -- draw - drawFrame - logicalDevice - swapchain - graphicsQueue - commandBuffers - renderPass - framebuffers - dimensions - pipelines - inFlightFence - imageAvailableSemaphore - renderFinishedSemaphore + drawFrame engineData -- poll events evs <- liftIO SDL.pollEvents -- flip abort condition on window close @@ -59,7 +49,7 @@ main = runResourceT $ do evs ) - Vk.deviceWaitIdle logicalDevice + Vk.deviceWaitIdle $ engineLogicalDevice engineData createBufferView :: (MonadResource m) diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal index 25257a6..2bddfc8 100644 --- a/vulkan-tutorial.cabal +++ b/vulkan-tutorial.cabal @@ -31,6 +31,7 @@ executable vulkan-tutorial Framebuffers CommandBuffer Draw + Types -- LANGUAGE extensions used by modules in this package. -- other-extensions: