a little cleanup

This commit is contained in:
nek0 2022-07-16 21:50:22 +02:00
parent 317d5916b0
commit 4c09e5d5a6
6 changed files with 171 additions and 192 deletions

View file

@ -34,7 +34,7 @@ createCommandPool physicalDevice logicalDevice = do
commandPool <- snd <$> allocate commandPool <- snd <$> allocate
(Vk.createCommandPool logicalDevice poolCreateInfo Nothing) (Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
(\commandPool -> do (\commandPool -> do
putStrLn "destroying comman pool" putStrLn "destroying command pool"
Vk.destroyCommandPool logicalDevice commandPool Nothing Vk.destroyCommandPool logicalDevice commandPool Nothing
) )

View file

@ -6,8 +6,6 @@ import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import qualified Data.Vector as V import qualified Data.Vector as V
import Foreign.C.Types (CInt)
import Linear (V2(..))
import qualified Vulkan.Core10 as Vk import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
import qualified Vulkan.CStruct.Extends as Vk import qualified Vulkan.CStruct.Extends as Vk
@ -16,81 +14,77 @@ import qualified Vulkan.Zero as Vk
-- internal imports -- internal imports
import CommandBuffer import CommandBuffer
import Types
drawFrame drawFrame
:: (MonadResource m) :: (MonadResource m)
=> Vk.Device => EngineData
-> 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
-> m () -> m ()
drawFrame drawFrame engineData = do
logicalDevice
swapchain
graphicsQueue
commandBuffers
renderPass
framebuffers
dimensions
pipelines
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
= do
unless (all (V.length commandBuffers ==) unless (all (V.length (engineCommandBuffers engineData) ==)
[V.length commandBuffers, V.length framebuffers, V.length pipelines]) $ [ V.length (engineCommandBuffers engineData)
error ("Numbers of elements mismatch: command buffers " <> show (V.length commandBuffers) <> , V.length (engineFramebuffers engineData)
", frame buffers " <> show (V.length framebuffers) <> , V.length (enginePipelines engineData)
", pipelines " <> show (V.length pipelines)) ]) $
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 void $ Vk.waitForFences (engineLogicalDevice engineData) fences True maxBound
Vk.resetFences logicalDevice fences Vk.resetFences (engineLogicalDevice engineData) fences
(imageResult, index) <- (imageResult, index) <-
Khr.acquireNextImageKHR logicalDevice swapchain maxBound imageAvailableSemaphore Vk.NULL_HANDLE Khr.acquireNextImageKHR
(engineLogicalDevice engineData)
(engineSwapchain engineData)
maxBound
(engineImageAvailableSemaphore engineData)
Vk.NULL_HANDLE
unless (imageResult == Vk.SUCCESS) $ unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain" error "drawFrame: Failed acquiring next image from swapchain"
liftIO $ putStrLn "resetting command buffer" -- liftIO $ putStrLn "resetting command buffer"
Vk.resetCommandBuffer (commandBuffers V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0) Vk.resetCommandBuffer
(engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
liftIO $ putStrLn "recording command buffer" -- liftIO $ putStrLn "recording command buffer"
recordCommandBuffer recordCommandBuffer
(commandBuffers V.! fromIntegral index) (engineCommandBuffers engineData V.! fromIntegral index)
renderPass (engineRenderPass engineData)
(framebuffers V.! fromIntegral index) (engineFramebuffers engineData V.! fromIntegral index)
dimensions (engineWindowDimensions engineData)
(pipelines V.! fromIntegral index) (enginePipelines engineData V.! fromIntegral index)
let submitInfo = Vk.zero let submitInfo = Vk.zero
{ Vk.waitSemaphores = V.singleton imageAvailableSemaphore { Vk.waitSemaphores =
, Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT V.singleton $ engineImageAvailableSemaphore engineData
, Vk.commandBuffers = V.singleton (Vk.commandBufferHandle $ commandBuffers V.! fromIntegral index) , Vk.waitDstStageMask =
, Vk.signalSemaphores = V.singleton renderFinishedSemaphore 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" -- liftIO $ putStrLn "submitting to queue"
Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence Vk.queueSubmit
(engineQueue engineData)
(V.singleton (Vk.SomeStruct submitInfo))
(engineInFlightFence engineData)
let presentInfo = Vk.zero let presentInfo = Vk.zero
{ Khr.waitSemaphores = V.singleton renderFinishedSemaphore { Khr.waitSemaphores = V.singleton $ engineRenderFinishedSemaphore engineData
, Khr.swapchains = V.singleton swapchain , Khr.swapchains = V.singleton $ engineSwapchain engineData
, Khr.imageIndices = V.singleton index , Khr.imageIndices = V.singleton index
} }
liftIO $ putStrLn "presenting queue" -- liftIO $ putStrLn "presenting queue"
presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo
unless (presentResult == Vk.SUCCESS) $ unless (presentResult == Vk.SUCCESS) $
error "drawFrame: presentation failed" error "drawFrame: presentation failed"

View file

@ -17,6 +17,9 @@ import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk import qualified Vulkan.Utils.ShaderQQ.GLSL.Shaderc as Vk
-- internal imports
import Types
loadShader loadShader
:: (MonadResource m) :: (MonadResource m)
=> Vk.Device => Vk.Device
@ -49,34 +52,86 @@ loadShader logicalDevice shaderPath stage = do
Vk.destroyShaderModule logicalDevice shaderModule Nothing 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 createGraphicsPipelines
:: (MonadResource m) :: (MonadResource m)
=> Vk.Device => Vk.Device
-> Vk.ShaderModule -> Vk.RenderPass
-> Vk.ShaderModule -> ShaderContainer
-> BS.ByteString -> BS.ByteString
-> V2 CInt -> V2 CInt
-> Vk.Format
-> Int -> Int
-> m (V.Vector Vk.Pipeline, Vk.RenderPass) -> Vk.PipelineLayout
-> m (V.Vector Vk.Pipeline)
createGraphicsPipelines createGraphicsPipelines
logicalDevice logicalDevice
vertexShaderModule renderPass
fragmentShaderModule shaderContainer
stageName stageName
(V2 width height) (V2 width height)
swapchainImageFormat
number number
pipelineLayout
= do = do
let vertexShaderStageCreateInfo = Vk.zero let vertexShaderStageCreateInfo = Vk.zero
{ Vk.stage = Vk.SHADER_STAGE_VERTEX_BIT { Vk.stage = Vk.SHADER_STAGE_VERTEX_BIT
, Vk.module' = vertexShaderModule , Vk.module' = containedVertexShader shaderContainer
, Vk.name = stageName , Vk.name = stageName
} }
fragmentShaderStageCreateInfo = Vk.zero fragmentShaderStageCreateInfo = Vk.zero
{ Vk.stage = Vk.SHADER_STAGE_FRAGMENT_BIT { Vk.stage = Vk.SHADER_STAGE_FRAGMENT_BIT
, Vk.module' = fragmentShaderModule , Vk.module' = containedFragmentShader shaderContainer
, Vk.name = stageName , Vk.name = stageName
} }
pipelineStagesCreateInfos = pipelineStagesCreateInfos =
@ -150,56 +205,7 @@ createGraphicsPipelines
{ Vk.logicOpEnable = False { Vk.logicOpEnable = False
, Vk.attachments = V.singleton colorBlendAttachment , Vk.attachments = V.singleton colorBlendAttachment
} }
pipelineLayoutCreateInfo = Vk.zero pipelineCreateInfo = 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
{ Vk.stageCount = 2 { Vk.stageCount = 2
, Vk.stages = pipelineStagesCreateInfos , Vk.stages = pipelineStagesCreateInfos
, Vk.vertexInputState = Just $ Vk.SomeStruct pipelineVertexInputCreateInfo , Vk.vertexInputState = Just $ Vk.SomeStruct pipelineVertexInputCreateInfo
@ -210,13 +216,13 @@ createGraphicsPipelines
, Vk.colorBlendState = Just $ Vk.SomeStruct pipelineColorBlendStateCreateInfo , Vk.colorBlendState = Just $ Vk.SomeStruct pipelineColorBlendStateCreateInfo
, Vk.dynamicState = Just pipelineDynamicStateCreateInfo , Vk.dynamicState = Just pipelineDynamicStateCreateInfo
, Vk.layout = pipelineLayout , Vk.layout = pipelineLayout
, Vk.renderPass = pipelineRenderPass , Vk.renderPass = renderPass
, Vk.subpass = 0 , Vk.subpass = 0
, Vk.basePipelineHandle = Vk.NULL_HANDLE , Vk.basePipelineHandle = Vk.NULL_HANDLE
, Vk.basePipelineIndex = -1 , Vk.basePipelineIndex = -1
} }
pipelines <- snd <$> allocate snd <$> allocate
(do (do
(result, pipelines) <- Vk.createGraphicsPipelines (result, pipelines) <- Vk.createGraphicsPipelines
logicalDevice logicalDevice
@ -235,4 +241,17 @@ createGraphicsPipelines
) )
pipelines 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
)

View file

@ -6,11 +6,8 @@ module Init where
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import qualified Data.Vector as V
import Linear (V2)
import qualified SDL hiding (V2) import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL import qualified SDL.Video.Vulkan as SDL
import Foreign.C.Types (CInt)
import Foreign.Ptr import Foreign.Ptr
import qualified Vulkan.Core10 as Vk import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr import qualified Vulkan.Extensions.VK_KHR_swapchain as Khr
@ -23,23 +20,11 @@ import Devices
import GraphicsPipeline import GraphicsPipeline
import Framebuffers import Framebuffers
import CommandBuffer import CommandBuffer
import Types
initEngine initEngine
:: (MonadResource m, MonadFail m) :: (MonadResource m, MonadFail m)
=> m => m EngineData
( 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
)
initEngine = do initEngine = do
-- initialize SDL2 with all subsystems -- initialize SDL2 with all subsystems
void $ allocate_ void $ allocate_
@ -72,20 +57,7 @@ initEngine = do
initVulkan initVulkan
:: (MonadResource m, MonadFail m) :: (MonadResource m, MonadFail m)
=> SDL.Window => SDL.Window
-> m -> m EngineData
( 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
)
initVulkan window = do initVulkan window = do
vulkanInstance <- createInstance window vulkanInstance <- createInstance window
@ -108,15 +80,18 @@ initVulkan window = do
imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice imageViews <- getImageViewHandles swapchain surfaceFormat vulkanLogicalDevice
vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert" vertexShader <- loadShader vulkanLogicalDevice "shadersrc/shader.vert" "vert"
fragmentShader <- loadShader vulkanLogicalDevice "shadersrc/shader.frag" "frag" 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 createGraphicsPipelines
vulkanLogicalDevice vulkanLogicalDevice
vertexShader renderPass
fragmentShader shaderContainer
"main" "main"
dimensions dimensions
(Khr.format surfaceFormat)
(length imageViews) (length imageViews)
pipelineLayout
frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
@ -126,17 +101,17 @@ initVulkan window = do
(imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <- (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
createSyncObjects vulkanLogicalDevice createSyncObjects vulkanLogicalDevice
return return $ EngineData
( window window
, dimensions dimensions
, vulkanLogicalDevice vulkanLogicalDevice
, swapchain swapchain
, graphicsQueue graphicsQueue
, commandBuffer commandBuffer
, frameBuffers frameBuffers
, pipelines pipelines
, renderPass renderPass
, inFlightFence inFlightFence
, imageAvailableSemaphore imageAvailableSemaphore
, renderFinishedSemaphore renderFinishedSemaphore
)

View file

@ -19,12 +19,13 @@ import qualified Vulkan.Zero as Vk
import Init import Init
import Draw (drawFrame) import Draw (drawFrame)
import Types
main :: IO () main :: IO ()
main = runResourceT $ do 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 -- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True quit <- liftIO $ STM.newTMVarIO True
@ -35,18 +36,7 @@ main = runResourceT $ do
) )
( do ( do
-- draw -- draw
drawFrame drawFrame engineData
logicalDevice
swapchain
graphicsQueue
commandBuffers
renderPass
framebuffers
dimensions
pipelines
inFlightFence
imageAvailableSemaphore
renderFinishedSemaphore
-- poll events -- poll events
evs <- liftIO SDL.pollEvents evs <- liftIO SDL.pollEvents
-- flip abort condition on window close -- flip abort condition on window close
@ -59,7 +49,7 @@ main = runResourceT $ do
evs evs
) )
Vk.deviceWaitIdle logicalDevice Vk.deviceWaitIdle $ engineLogicalDevice engineData
createBufferView createBufferView
:: (MonadResource m) :: (MonadResource m)

View file

@ -31,6 +31,7 @@ executable vulkan-tutorial
Framebuffers Framebuffers
CommandBuffer CommandBuffer
Draw Draw
Types
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions: