From 83950010ac936d572d3dca1ba294294ea182f973 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 14 Jul 2022 07:02:10 +0200 Subject: [PATCH] almost drawing, just fix shaders --- src/CommandBuffer.hs | 18 ++++++---- src/Draw.hs | 65 ++++++++++++++++++++++++++++++++++++ src/Framebuffers.hs | 11 ++---- src/GraphicsPipeline.hs | 22 ++++++++---- src/Init.hs | 74 ++++++++++++++++++++++++++++++++++------- src/Main.hs | 21 +++++++++--- vulkan-tutorial.cabal | 1 + 7 files changed, 174 insertions(+), 38 deletions(-) create mode 100644 src/Draw.hs diff --git a/src/CommandBuffer.hs b/src/CommandBuffer.hs index 993975e..7dee642 100644 --- a/src/CommandBuffer.hs +++ b/src/CommandBuffer.hs @@ -19,7 +19,7 @@ createCommandPool :: (MonadResource m) => Vk.PhysicalDevice -> Vk.Device - -> m Vk.CommandPool + -> m (Vk.CommandPool, Vk.Queue) createCommandPool physicalDevice logicalDevice = do queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT @@ -29,19 +29,23 @@ createCommandPool physicalDevice logicalDevice = do , Vk.queueFamilyIndex = queueFamilyIndex } :: Vk.CommandPoolCreateInfo - snd <$> allocate + graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0 + + commandPool <- snd <$> allocate (Vk.createCommandPool logicalDevice poolCreateInfo Nothing) (\commandPool -> do putStrLn "destroying comman pool" Vk.destroyCommandPool logicalDevice commandPool Nothing ) + return (commandPool, graphicsQueue) + createCommandBuffer :: (MonadResource m) - => Vk.CommandPool - -> Vk.Device + => Vk.Device + -> Vk.CommandPool -> m (V.Vector Vk.CommandBuffer) -createCommandBuffer commandPool logicalDevice = do +createCommandBuffer logicalDevice commandPool = do let commandBufferAllocationInfo = Vk.zero { Vk.commandPool = commandPool @@ -123,6 +127,8 @@ createSyncObjects logicalDevice = do let semaphoreCreateInfo = Vk.zero fenceCreateInfo = Vk.zero + { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT + } :: Vk.FenceCreateInfo '[] [imageAvailableSemaphore, renderFinishedSemaphore] <- replicateM 2 (snd <$> allocate @@ -134,4 +140,4 @@ createSyncObjects logicalDevice = do ) inFlightFence <- Vk.createFence logicalDevice fenceCreateInfo Nothing - return (imageAvailableSemaphore, renderFinishedSemaphore,inFlightFence) + return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) diff --git a/src/Draw.hs b/src/Draw.hs new file mode 100644 index 0000000..2530ab9 --- /dev/null +++ b/src/Draw.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +module Draw where + +import Control.Monad +import Control.Monad.Trans.Resource +import qualified Data.Vector as V +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr +import qualified Vulkan.CStruct.Extends as Vk +import qualified Vulkan.Zero as Vk + + +drawFrame + :: (MonadResource m) + => Vk.Device + -> Khr.SwapchainKHR + -> Vk.Queue + -> Vk.CommandBuffer + -> Vk.Fence + -> Vk.Semaphore + -> Vk.Semaphore + -> m () +drawFrame + logicalDevice + swapchain + graphicsQueue + commandBuffer + inFlightFence + imageAvailableSemaphore + renderFinishedSemaphore + = do + + let fences = V.singleton inFlightFence + + void $ Vk.waitForFences logicalDevice fences True maxBound + Vk.resetFences logicalDevice fences + + (imageResult, index) <- + Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore inFlightFence + + unless (imageResult == Vk.SUCCESS) $ + error "drawFrame: Failed acquiring next image from swapchain" + + Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0) + + 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 commandBuffer) + , Vk.signalSemaphores = V.singleton renderFinishedSemaphore + } + + Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence + + let presentInfo = Vk.zero + { Khr.waitSemaphores = V.singleton renderFinishedSemaphore + , Khr.swapchains = V.singleton swapchain + , Khr.imageIndices = V.singleton index + } + + presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo + + unless (presentResult == Vk.SUCCESS) $ + error "drawFrame: presentation failed" diff --git a/src/Framebuffers.hs b/src/Framebuffers.hs index 4f41859..5dae560 100644 --- a/src/Framebuffers.hs +++ b/src/Framebuffers.hs @@ -4,26 +4,21 @@ module Framebuffers where import Linear -import Control.Monad (unless) -import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource -import Data.Bits -import qualified Data.ByteString as BS import qualified Data.Vector as V import Foreign.C.Types (CInt) import qualified Vulkan as Vk import qualified Vulkan.Zero as Vk -import qualified Vulkan.CStruct.Extends as Vk createFramebuffer :: (MonadResource m) - => Vk.RenderPass + => Vk.Device + -> Vk.RenderPass -> V.Vector Vk.ImageView -> V2 CInt - -> Vk.Device -> m Vk.Framebuffer -createFramebuffer renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight) logicalDevice +createFramebuffer logicalDevice renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight) = do let framebufferCreateInfo = Vk.zero diff --git a/src/GraphicsPipeline.hs b/src/GraphicsPipeline.hs index 9728f4b..32146cb 100644 --- a/src/GraphicsPipeline.hs +++ b/src/GraphicsPipeline.hs @@ -11,7 +11,7 @@ import Data.Bits import qualified Data.ByteString as BS import qualified Data.Vector as V import Foreign.C.Types (CInt) -import qualified Vulkan as Vk +import qualified Vulkan.Core10 as Vk import qualified Vulkan.Zero as Vk import qualified Vulkan.CStruct.Extends as Vk @@ -36,20 +36,20 @@ loadShader logicalDevice shaderPath = do createGraphicsPipelines :: (MonadResource m) - => Vk.ShaderModule + => Vk.Device + -> Vk.ShaderModule -> Vk.ShaderModule -> BS.ByteString -> V2 CInt -> Vk.Format - -> Vk.Device - -> m (V.Vector Vk.Pipeline) + -> m (V.Vector Vk.Pipeline, Vk.RenderPass) createGraphicsPipelines + logicalDevice vertexShaderModule fragmentShaderModule stageName (V2 width height) swapchainImageFormat - logicalDevice = do let vertexShaderStageCreateInfo = Vk.zero @@ -160,10 +160,16 @@ createGraphicsPipelines { 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.srcAccessMask = Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT + } renderPassCreateInfo = Vk.zero { Vk.attachments = V.singleton colorAttachmentDescription , Vk.subpasses = V.singleton subpassDescriptor - , Vk.dependencies = V.empty + , Vk.dependencies = V.singleton subpassDependency } :: Vk.RenderPassCreateInfo '[] pipelineRenderPass <- snd <$> allocate @@ -190,7 +196,7 @@ createGraphicsPipelines , Vk.basePipelineIndex = -1 } - snd <$> allocate + pipelines <- snd <$> allocate (do (result, pipelines) <- Vk.createGraphicsPipelines logicalDevice @@ -209,3 +215,5 @@ createGraphicsPipelines ) pipelines ) + + return (pipelines, pipelineRenderPass) diff --git a/src/Init.hs b/src/Init.hs index 79f874b..c61db0f 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -10,16 +10,30 @@ import qualified Data.Vector as V import qualified SDL hiding (V2) import qualified SDL.Video.Vulkan as SDL import Foreign.Ptr -import qualified Vulkan as Vk +import qualified Vulkan.Core10 as Vk +import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr +import qualified Vulkan.Extensions.VK_KHR_surface as Khr -- internal imports import Instance import Devices +import GraphicsPipeline +import Framebuffers +import CommandBuffer initEngine - :: MonadResource m - => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.ImageView) + :: (MonadResource m, MonadFail m) + => m + ( SDL.Window + , Vk.Device + , Khr.SwapchainKHR + , Vk.Queue + , V.Vector Vk.CommandBuffer + , Vk.Fence + , Vk.Semaphore + , Vk.Semaphore + ) initEngine = do -- initialize SDL2 with all subsystems void $ allocate_ @@ -46,32 +60,68 @@ initEngine = do SDL.destroyWindow window ) - -- create vulkan surface and vulkan instance from window - (surface, inst, swapchain, images) <- initVulkan window - return (window, inst, surface, swapchain, images) + -- initialize viúlkan data structures + initVulkan window initVulkan - :: MonadResource m + :: (MonadResource m, MonadFail m) => SDL.Window - -> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.ImageView) + -> m + ( SDL.Window + , Vk.Device + , Khr.SwapchainKHR + , Vk.Queue + , V.Vector Vk.CommandBuffer + , Vk.Fence + , Vk.Semaphore + , Vk.Semaphore + ) initVulkan window = do vulkanInstance <- createInstance window (_, vulkanSurface) <- allocate - (Vk.SurfaceKHR <$> + (Khr.SurfaceKHR <$> SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) ) (\vulkanSurface -> do putStrLn "destroying surface" - Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing + Khr.destroySurfaceKHR vulkanInstance vulkanSurface Nothing ) vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window - (swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice + (swapchain, surfaceFormat) <- + createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice + vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" + fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" + (pipelines, renderPass) <- + createGraphicsPipelines + vulkanLogicalDevice + vertexShader + fragmentShader + "main" + dimensions + (Khr.format surfaceFormat) - return (vulkanSurface, vulkanInstance, swapchain, imageViews) + frameBuffer <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions + + (commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice + commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool + + (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <- + createSyncObjects vulkanLogicalDevice + + return + ( window + , vulkanLogicalDevice + , swapchain + , graphicsQueue + , commandBuffer + , inFlightFence + , imageAvailableSemaphore + , renderFinishedSemaphore + ) diff --git a/src/Main.hs b/src/Main.hs index 784dcaf..03bfb8a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,6 +8,7 @@ import Control.Monad.Loops import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Bits +import qualified Data.Vector as V import Data.Word import qualified SDL hiding (V2) import qualified Control.Concurrent.STM as STM @@ -17,10 +18,11 @@ import qualified Vulkan.Zero as Vk -- internal imports import Init +import Draw (drawFrame) main :: IO () main = runResourceT $ do - (window, inst, surface, swapchain, images) <- initEngine + (window, logicalDevice, swapchain, graphicsQueue, commandBuffer, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine SDL.showWindow window @@ -28,17 +30,26 @@ main = runResourceT $ do quit <- liftIO $ STM.newTMVarIO True -- main loop - liftIO $ whileM_ - (STM.atomically $ STM.readTMVar quit + whileM_ + (liftIO $ STM.atomically $ STM.readTMVar quit ) ( do + -- draw + drawFrame + logicalDevice + swapchain + graphicsQueue + (V.head commandBuffer) + inFlightFence + imageAvailableSemaphore + renderFinishedSemaphore -- poll events - evs <- SDL.pollEvents + evs <- liftIO SDL.pollEvents -- flip abort condition on window close mapM_ (\e -> case SDL.eventPayload e of SDL.WindowClosedEvent _ -> - void $ STM.atomically $ STM.swapTMVar quit False + void $ liftIO $ STM.atomically $ STM.swapTMVar quit False _ -> return () ) evs diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal index d99602b..1cd814f 100644 --- a/vulkan-tutorial.cabal +++ b/vulkan-tutorial.cabal @@ -30,6 +30,7 @@ executable vulkan-tutorial GraphicsPipeline Framebuffers CommandBuffer + Draw -- LANGUAGE extensions used by modules in this package. -- other-extensions: