diff --git a/shell.nix b/shell.nix index a56919f..173e6bb 100644 --- a/shell.nix +++ b/shell.nix @@ -3,5 +3,16 @@ let vulkanTutorial = pkgs.haskellPackages.callCabal2nix "vulkan-tutorial" (gitignore ./.) {}; gitignore = src: pkgs.nix-gitignore.gitignoreSource [] src; + hpkgs = pkgs.haskellPackages.override { + overrides = final: prev: { + vulkanTutorial = vulkanTutorial; + }; + }; in - vulkanTutorial.env + hpkgs.shellFor { + packages = p: [ + p.vulkanTutorial + ]; + buildInputs = + vulkanTutorial.buildInputs ++ [ pkgs.shaderc ]; + } diff --git a/src/CommandBuffer.hs b/src/CommandBuffer.hs index 7dee642..73e80db 100644 --- a/src/CommandBuffer.hs +++ b/src/CommandBuffer.hs @@ -14,6 +14,7 @@ import qualified Vulkan.Zero as Vk -- internal imports import Devices +import GHC.IO.Handle.Text (commitBuffer') createCommandPool :: (MonadResource m) @@ -85,7 +86,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph , Vk.height = fromIntegral height } } - , Vk.clearValues = V.singleton (Vk.Color $ Vk.Float32 0 0 0 1) + , Vk.clearValues = V.replicate 4 (Vk.Color $ Vk.Float32 0 0 0 1) } Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE @@ -118,6 +119,7 @@ recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graph Vk.cmdEndRenderPass commandBuffer + Vk.endCommandBuffer commandBuffer createSyncObjects :: (MonadResource m, MonadFail m) @@ -138,6 +140,11 @@ createSyncObjects logicalDevice = do Vk.destroySemaphore logicalDevice semaphore Nothing ) ) - inFlightFence <- Vk.createFence logicalDevice fenceCreateInfo Nothing + inFlightFence <- snd <$> allocate + (Vk.createFence logicalDevice fenceCreateInfo Nothing) + (\fence -> do + putStrLn "destroying fence" + Vk.destroyFence logicalDevice fence Nothing + ) return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) diff --git a/src/Devices.hs b/src/Devices.hs index 865928f..2edc9d3 100644 --- a/src/Devices.hs +++ b/src/Devices.hs @@ -153,7 +153,7 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice = do (\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension , Vk.imageArrayLayers = 1 , Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT - , Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR + , Vk.presentMode = Vk.PRESENT_MODE_FIFO_KHR , Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR , Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_OPAQUE_BIT_KHR , Vk.clipped = True diff --git a/src/Draw.hs b/src/Draw.hs index 2530ab9..cc5e2be 100644 --- a/src/Draw.hs +++ b/src/Draw.hs @@ -5,11 +5,16 @@ module Draw where import Control.Monad 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 import qualified Vulkan.Zero as Vk +-- internal imports + +import CommandBuffer drawFrame :: (MonadResource m) @@ -17,6 +22,10 @@ drawFrame -> Khr.SwapchainKHR -> Vk.Queue -> Vk.CommandBuffer + -> Vk.RenderPass + -> Vk.Framebuffer + -> V2 CInt + -> Vk.Pipeline -> Vk.Fence -> Vk.Semaphore -> Vk.Semaphore @@ -26,6 +35,10 @@ drawFrame swapchain graphicsQueue commandBuffer + renderPass + framebuffer + dimensions + pipeline inFlightFence imageAvailableSemaphore renderFinishedSemaphore @@ -37,13 +50,15 @@ drawFrame Vk.resetFences logicalDevice fences (imageResult, index) <- - Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore inFlightFence + Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE unless (imageResult == Vk.SUCCESS) $ error "drawFrame: Failed acquiring next image from swapchain" Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0) + recordCommandBuffer commandBuffer renderPass framebuffer dimensions pipeline + let submitInfo = Vk.zero { Vk.waitSemaphores = V.singleton imageAvailableSemaphore , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT diff --git a/src/GraphicsPipeline.hs b/src/GraphicsPipeline.hs index 32146cb..57c9639 100644 --- a/src/GraphicsPipeline.hs +++ b/src/GraphicsPipeline.hs @@ -8,23 +8,38 @@ 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.ByteString as BS +import qualified Data.ByteString.Char8 as BS import qualified Data.Vector as V import Foreign.C.Types (CInt) import qualified Vulkan.Core10 as Vk import qualified Vulkan.Zero as Vk import qualified Vulkan.CStruct.Extends as Vk +import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk loadShader :: (MonadResource m) => Vk.Device -> FilePath + -> String -> m Vk.ShaderModule -loadShader logicalDevice shaderPath = do +loadShader logicalDevice shaderPath stage = do shaderSource <- liftIO $ BS.readFile shaderPath + (warnings, eShader) <- Vk.compileShader Nothing Nothing stage (BS.unpack shaderSource) + unless (null warnings) $ liftIO $ do + putStrLn "loadShader: Shader compilation warnings:" + print warnings + shader <- either + (\errors -> do + error ("loadShader: Compilation errors:" <> "\n" <> show errors) + ) + return + eShader + + let createInfo = Vk.zero - { Vk.code = shaderSource + { Vk.code = shader } snd <$> allocate @@ -161,13 +176,16 @@ createGraphicsPipelines , 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.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.attachments = V.replicate 4 colorAttachmentDescription , Vk.subpasses = V.singleton subpassDescriptor , Vk.dependencies = V.singleton subpassDependency } :: Vk.RenderPassCreateInfo '[] diff --git a/src/Init.hs b/src/Init.hs index c61db0f..34949c9 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -7,8 +7,10 @@ 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 @@ -26,10 +28,14 @@ initEngine :: (MonadResource m, MonadFail m) => m ( SDL.Window + , V2 CInt , Vk.Device , Khr.SwapchainKHR , Vk.Queue , V.Vector Vk.CommandBuffer + , Vk.Framebuffer + , V.Vector Vk.Pipeline + , Vk.RenderPass , Vk.Fence , Vk.Semaphore , Vk.Semaphore @@ -68,10 +74,14 @@ initVulkan => SDL.Window -> m ( SDL.Window + , V2 CInt , Vk.Device , Khr.SwapchainKHR , Vk.Queue , V.Vector Vk.CommandBuffer + , Vk.Framebuffer + , V.Vector Vk.Pipeline + , Vk.RenderPass , Vk.Fence , Vk.Semaphore , Vk.Semaphore @@ -96,8 +106,8 @@ initVulkan window = do (swapchain, surfaceFormat) <- createSwapchain vulkanSurface surfaceFormats dimensions vulkanLogicalDevice imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice - vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" - fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" + vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert" + fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag" (pipelines, renderPass) <- createGraphicsPipelines vulkanLogicalDevice @@ -117,10 +127,14 @@ initVulkan window = do return ( window + , dimensions , vulkanLogicalDevice , swapchain , graphicsQueue , commandBuffer + , frameBuffer + , pipelines + , renderPass , inFlightFence , imageAvailableSemaphore , renderFinishedSemaphore diff --git a/src/Main.hs b/src/Main.hs index 03bfb8a..bc0af95 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -22,7 +22,7 @@ import Draw (drawFrame) main :: IO () main = runResourceT $ do - (window, logicalDevice, swapchain, graphicsQueue, commandBuffer, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine + (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffer, framebuffer, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine SDL.showWindow window @@ -40,6 +40,10 @@ main = runResourceT $ do swapchain graphicsQueue (V.head commandBuffer) + renderPass + framebuffer + dimensions + (V.head pipelines) inFlightFence imageAvailableSemaphore renderFinishedSemaphore @@ -55,6 +59,8 @@ main = runResourceT $ do evs ) + Vk.deviceWaitIdle logicalDevice + createBufferView :: (MonadResource m) => Vk.Device diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal index 1cd814f..25257a6 100644 --- a/vulkan-tutorial.cabal +++ b/vulkan-tutorial.cabal @@ -38,7 +38,6 @@ executable vulkan-tutorial , sdl2 , vulkan , vulkan-utils - , VulkanMemoryAllocator , linear , monad-loops , stm