fix multiple frames

This commit is contained in:
nek0 2022-07-16 16:36:51 +02:00
parent 886498e4c4
commit 317d5916b0
7 changed files with 60 additions and 31 deletions

View file

@ -44,8 +44,9 @@ createCommandBuffer
:: (MonadResource m) :: (MonadResource m)
=> Vk.Device => Vk.Device
-> Vk.CommandPool -> Vk.CommandPool
-> Int
-> m (V.Vector Vk.CommandBuffer) -> m (V.Vector Vk.CommandBuffer)
createCommandBuffer logicalDevice commandPool = do createCommandBuffer logicalDevice commandPool number = do
let commandBufferAllocationInfo = Vk.zero let commandBufferAllocationInfo = Vk.zero
{ Vk.commandPool = commandPool { Vk.commandPool = commandPool
@ -53,7 +54,8 @@ createCommandBuffer logicalDevice commandPool = do
, Vk.commandBufferCount = 1 , Vk.commandBufferCount = 1
} }
Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo V.concat <$>
replicateM number (Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo)
recordCommandBuffer recordCommandBuffer
:: (MonadResource m) :: (MonadResource m)

View file

@ -179,6 +179,9 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do
when (result /= Vk.SUCCESS) $ when (result /= Vk.SUCCESS) $
error "getImageHandles: Failed acquiring images from swapchain" error "getImageHandles: Failed acquiring images from swapchain"
liftIO $
putStrLn ("number of images: " <> show (V.length handles))
V.mapM V.mapM
(\image -> do (\image -> do
let createInfo = Vk.zero let createInfo = Vk.zero

View file

@ -3,6 +3,7 @@
module Draw where module Draw where
import Control.Monad import Control.Monad
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 Foreign.C.Types (CInt)
@ -21,11 +22,11 @@ drawFrame
=> Vk.Device => Vk.Device
-> Khr.SwapchainKHR -> Khr.SwapchainKHR
-> Vk.Queue -> Vk.Queue
-> Vk.CommandBuffer -> V.Vector Vk.CommandBuffer
-> Vk.RenderPass -> Vk.RenderPass
-> Vk.Framebuffer -> V.Vector Vk.Framebuffer
-> V2 CInt -> V2 CInt
-> Vk.Pipeline -> V.Vector Vk.Pipeline
-> Vk.Fence -> Vk.Fence
-> Vk.Semaphore -> Vk.Semaphore
-> Vk.Semaphore -> Vk.Semaphore
@ -34,16 +35,22 @@ drawFrame
logicalDevice logicalDevice
swapchain swapchain
graphicsQueue graphicsQueue
commandBuffer commandBuffers
renderPass renderPass
framebuffer framebuffers
dimensions dimensions
pipeline pipelines
inFlightFence inFlightFence
imageAvailableSemaphore imageAvailableSemaphore
renderFinishedSemaphore renderFinishedSemaphore
= do = 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))
let fences = V.singleton inFlightFence let fences = V.singleton inFlightFence
void $ Vk.waitForFences logicalDevice fences True maxBound void $ Vk.waitForFences logicalDevice fences True maxBound
@ -55,25 +62,34 @@ drawFrame
unless (imageResult == Vk.SUCCESS) $ unless (imageResult == Vk.SUCCESS) $
error "drawFrame: Failed acquiring next image from swapchain" error "drawFrame: Failed acquiring next image from swapchain"
Vk.resetCommandBuffer commandBuffer (Vk.CommandBufferResetFlagBits 0) liftIO $ putStrLn "resetting command buffer"
Vk.resetCommandBuffer (commandBuffers V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
recordCommandBuffer commandBuffer renderPass framebuffer dimensions pipeline liftIO $ putStrLn "recording command buffer"
recordCommandBuffer
(commandBuffers V.! fromIntegral index)
renderPass
(framebuffers V.! fromIntegral index)
dimensions
(pipelines V.! fromIntegral index)
let submitInfo = Vk.zero let submitInfo = Vk.zero
{ Vk.waitSemaphores = V.singleton imageAvailableSemaphore { Vk.waitSemaphores = V.singleton imageAvailableSemaphore
, Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT , Vk.waitDstStageMask = V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
, Vk.commandBuffers = V.singleton (Vk.commandBufferHandle commandBuffer) , Vk.commandBuffers = V.singleton (Vk.commandBufferHandle $ commandBuffers V.! fromIntegral index)
, Vk.signalSemaphores = V.singleton renderFinishedSemaphore , Vk.signalSemaphores = V.singleton renderFinishedSemaphore
} }
liftIO $ putStrLn "submitting to queue"
Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence Vk.queueSubmit graphicsQueue (V.singleton (Vk.SomeStruct submitInfo)) inFlightFence
let presentInfo = Vk.zero let presentInfo = Vk.zero
{ Khr.waitSemaphores = V.singleton renderFinishedSemaphore { Khr.waitSemaphores = V.singleton renderFinishedSemaphore
, Khr.swapchains = V.singleton swapchain , Khr.swapchains = V.singleton swapchain
, Khr.imageIndices = V.singleton 0 , Khr.imageIndices = V.singleton index
} }
liftIO $ putStrLn "presenting queue"
presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo presentResult <- Khr.queuePresentKHR graphicsQueue presentInfo
unless (presentResult == Vk.SUCCESS) $ unless (presentResult == Vk.SUCCESS) $

View file

@ -17,21 +17,27 @@ createFramebuffer
-> Vk.RenderPass -> Vk.RenderPass
-> V.Vector Vk.ImageView -> V.Vector Vk.ImageView
-> V2 CInt -> V2 CInt
-> m Vk.Framebuffer -> m (V.Vector Vk.Framebuffer)
createFramebuffer logicalDevice renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight) createFramebuffer logicalDevice renderPass swapchainImageViews (V2 swapchainWidth swapcheinHeight)
= do = do
let framebufferCreateInfo = Vk.zero let framebufferCreateInfo = Vk.zero
{ Vk.renderPass = renderPass { Vk.renderPass = renderPass
, Vk.attachments = swapchainImageViews
, Vk.width = fromIntegral swapchainWidth , Vk.width = fromIntegral swapchainWidth
, Vk.height = fromIntegral swapcheinHeight , Vk.height = fromIntegral swapcheinHeight
, Vk.layers = 1 , Vk.layers = 1
} }
snd <$> allocate V.mapM
(Vk.createFramebuffer logicalDevice framebufferCreateInfo Nothing) (\imageView -> do
(\framebuffer -> do let createInfo = framebufferCreateInfo
putStrLn "destroying framebuffer" { Vk.attachments = V.singleton imageView
Vk.destroyFramebuffer logicalDevice framebuffer Nothing } :: Vk.FramebufferCreateInfo '[]
snd <$> allocate
(Vk.createFramebuffer logicalDevice createInfo Nothing)
(\framebuffer -> do
putStrLn "destroying framebuffer"
Vk.destroyFramebuffer logicalDevice framebuffer Nothing
)
) )
swapchainImageViews

View file

@ -57,6 +57,7 @@ createGraphicsPipelines
-> BS.ByteString -> BS.ByteString
-> V2 CInt -> V2 CInt
-> Vk.Format -> Vk.Format
-> Int
-> m (V.Vector Vk.Pipeline, Vk.RenderPass) -> m (V.Vector Vk.Pipeline, Vk.RenderPass)
createGraphicsPipelines createGraphicsPipelines
logicalDevice logicalDevice
@ -65,6 +66,7 @@ createGraphicsPipelines
stageName stageName
(V2 width height) (V2 width height)
swapchainImageFormat swapchainImageFormat
number
= do = do
let vertexShaderStageCreateInfo = Vk.zero let vertexShaderStageCreateInfo = Vk.zero
@ -185,7 +187,7 @@ createGraphicsPipelines
Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT
} }
renderPassCreateInfo = Vk.zero renderPassCreateInfo = Vk.zero
{ Vk.attachments = V.replicate 4 colorAttachmentDescription { Vk.attachments = V.singleton colorAttachmentDescription
, Vk.subpasses = V.singleton subpassDescriptor , Vk.subpasses = V.singleton subpassDescriptor
, Vk.dependencies = V.singleton subpassDependency , Vk.dependencies = V.singleton subpassDependency
} :: Vk.RenderPassCreateInfo '[] } :: Vk.RenderPassCreateInfo '[]
@ -219,7 +221,7 @@ createGraphicsPipelines
(result, pipelines) <- Vk.createGraphicsPipelines (result, pipelines) <- Vk.createGraphicsPipelines
logicalDevice logicalDevice
Vk.NULL_HANDLE Vk.NULL_HANDLE
(V.singleton (Vk.SomeStruct pipelineCreateInfo)) (V.replicate number (Vk.SomeStruct pipelineCreateInfo))
Nothing Nothing
unless (result == Vk.SUCCESS) $ unless (result == Vk.SUCCESS) $
error "createGraphicsPiepelines: Failed creating pipelines" error "createGraphicsPiepelines: Failed creating pipelines"
@ -233,5 +235,4 @@ createGraphicsPipelines
) )
pipelines pipelines
) )
return (pipelines, pipelineRenderPass) return (pipelines, pipelineRenderPass)

View file

@ -33,7 +33,7 @@ initEngine
, Khr.SwapchainKHR , Khr.SwapchainKHR
, Vk.Queue , Vk.Queue
, V.Vector Vk.CommandBuffer , V.Vector Vk.CommandBuffer
, Vk.Framebuffer , V.Vector Vk.Framebuffer
, V.Vector Vk.Pipeline , V.Vector Vk.Pipeline
, Vk.RenderPass , Vk.RenderPass
, Vk.Fence , Vk.Fence
@ -79,7 +79,7 @@ initVulkan
, Khr.SwapchainKHR , Khr.SwapchainKHR
, Vk.Queue , Vk.Queue
, V.Vector Vk.CommandBuffer , V.Vector Vk.CommandBuffer
, Vk.Framebuffer , V.Vector Vk.Framebuffer
, V.Vector Vk.Pipeline , V.Vector Vk.Pipeline
, Vk.RenderPass , Vk.RenderPass
, Vk.Fence , Vk.Fence
@ -116,11 +116,12 @@ initVulkan window = do
"main" "main"
dimensions dimensions
(Khr.format surfaceFormat) (Khr.format surfaceFormat)
(length imageViews)
frameBuffer <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews dimensions
(commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice (commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool (length frameBuffers)
(imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <- (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
createSyncObjects vulkanLogicalDevice createSyncObjects vulkanLogicalDevice
@ -132,7 +133,7 @@ initVulkan window = do
, swapchain , swapchain
, graphicsQueue , graphicsQueue
, commandBuffer , commandBuffer
, frameBuffer , frameBuffers
, pipelines , pipelines
, renderPass , renderPass
, inFlightFence , inFlightFence

View file

@ -22,7 +22,7 @@ import Draw (drawFrame)
main :: IO () main :: IO ()
main = runResourceT $ do main = runResourceT $ do
(window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffer, framebuffer, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine (window, dimensions, logicalDevice, swapchain, graphicsQueue, commandBuffers, framebuffers, pipelines, renderPass, inFlightFence, imageAvailableSemaphore, renderFinishedSemaphore) <- initEngine
SDL.showWindow window SDL.showWindow window
@ -39,11 +39,11 @@ main = runResourceT $ do
logicalDevice logicalDevice
swapchain swapchain
graphicsQueue graphicsQueue
(V.head commandBuffer) commandBuffers
renderPass renderPass
framebuffer framebuffers
dimensions dimensions
(V.head pipelines) pipelines
inFlightFence inFlightFence
imageAvailableSemaphore imageAvailableSemaphore
renderFinishedSemaphore renderFinishedSemaphore