enable double buffering

src/CommandBuffer.hs

@@ -22,12 +22,15 @@ import qualified Vulkan.Zero as Vk
 import Devices
 import Types
 
-createCommandPool
+frameOverlap :: Int
-  :: (MonadResource m)
+frameOverlap = 2
+
+createFrames
+  :: (MonadResource m, MonadFail m)
   => Vk.PhysicalDevice
   -> Vk.Device
-  -> m (Vk.CommandPool, Vk.Queue)
+  -> m (V.Vector FrameData, Vk.Queue)
-createCommandPool physicalDevice logicalDevice = do
+createFrames physicalDevice logicalDevice = do
 
   queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
 
@@ -38,31 +41,56 @@ createCommandPool physicalDevice logicalDevice = do
 
   graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0
 
-  commandPool <- snd <$> allocate
+  frames <- V.mapM
-    (Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
+    (\_ -> do
-    (\commandPool -> do
-      putStrLn "destroying command pool"
-      Vk.destroyCommandPool logicalDevice commandPool Nothing
-      )
 
-  return (commandPool, graphicsQueue)
+      commandPool <- snd <$> allocate
+        (Vk.createCommandPool logicalDevice poolCreateInfo Nothing)
+        (\commandPool -> do
+          putStrLn "destroying command pool"
+          Vk.destroyCommandPool logicalDevice commandPool Nothing
+          )
 
-createCommandBuffer
+      let commandBufferAllocationInfo = Vk.zero
-  :: (MonadResource m)
+            { Vk.commandPool        = commandPool
-  => Vk.Device
+            , Vk.level              = Vk.COMMAND_BUFFER_LEVEL_PRIMARY
-  -> Vk.CommandPool
+            , Vk.commandBufferCount = 1
-  -> Int
+            }
-  -> m (V.Vector Vk.CommandBuffer)
-createCommandBuffer logicalDevice commandPool number = do
 
-  let commandBufferAllocationInfo = Vk.zero
+      commandBuffer <- Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo
-        { Vk.commandPool        = commandPool
+
-        , Vk.level              = Vk.COMMAND_BUFFER_LEVEL_PRIMARY
+      let semaphoreCreateInfo = Vk.zero
-        , Vk.commandBufferCount = 1
+          fenceCreateInfo = Vk.zero
+            { Vk.flags = Vk.FENCE_CREATE_SIGNALED_BIT
+            } :: Vk.FenceCreateInfo '[]
+
+      [presentSemaphore, renderSemaphore] <- replicateM 2
+        (snd <$> allocate
+          (Vk.createSemaphore logicalDevice semaphoreCreateInfo Nothing)
+          (\semaphore -> do
+            putStrLn "destroying semaphore"
+            Vk.destroySemaphore logicalDevice semaphore Nothing
+            )
+          )
+      renderFence <- snd <$> allocate
+        (Vk.createFence logicalDevice fenceCreateInfo Nothing)
+        (\fence -> do
+          putStrLn "destroying fence"
+          Vk.destroyFence logicalDevice fence Nothing
+          )
+
+      return FrameData
+        { framePresentSemaphore  = presentSemaphore
+        , frameRenderSemaphore   = renderSemaphore
+        , frameRenderFence       = renderFence
+        , frameCommandPool       = commandPool
+        , frameMainCommandBuffer = V.head commandBuffer
         }
 
-  V.concat <$>
+      )
-    replicateM number (Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo)
+    (V.fromList [1 .. frameOverlap])
+
+  return (frames, graphicsQueue)
 
 recordCommandBuffer
   :: (MonadResource m, MonadReader ReadState m, MonadIO m)
@@ -170,31 +198,3 @@ recordCommandBuffer
     Vk.cmdEndRenderPass commandBuffer
 
     Vk.endCommandBuffer commandBuffer
-
-createSyncObjects
-  :: (MonadResource m, MonadFail m)
-  => Vk.Device
-  -> m (Vk.Semaphore, Vk.Semaphore, Vk.Fence)
-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
-      (Vk.createSemaphore logicalDevice semaphoreCreateInfo Nothing)
-      (\semaphore -> do
-        putStrLn "destroying semaphore"
-        Vk.destroySemaphore logicalDevice semaphore Nothing
-        )
-      )
-  inFlightFence <- snd <$> allocate
-    (Vk.createFence logicalDevice fenceCreateInfo Nothing)
-    (\fence -> do
-      putStrLn "destroying fence"
-      Vk.destroyFence logicalDevice fence Nothing
-      )
-
-  return (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence)

src/Draw.hs

@@ -19,33 +19,30 @@ import qualified Vulkan.Zero as Vk
 
 import CommandBuffer
 import Types
+import Util (getFrame)
 
 drawFrame
   :: (MonadResource m, MonadFail m, MonadReader ReadState m)
   => EngineData
+  -> Int
   -> m ()
-drawFrame engineData = do
+drawFrame engineData frameNumber = do
 
-  unless (all (V.length (engineCommandBuffers engineData) ==)
+  let frame = getFrame engineData frameNumber
-    [ V.length (engineCommandBuffers engineData)
-    , V.length (engineFramebuffers engineData)
-    ]) $
-      error ("Numbers of elements mismatch: command buffers " <>
-        show (V.length $ engineCommandBuffers engineData) <>
-        ", frame buffers " <> show (V.length $ engineFramebuffers engineData)
-        )
 
-  let fences = V.singleton $ engineInFlightFence engineData
+  void $ Vk.waitForFences
-
+    (engineLogicalDevice engineData)
-  void $ Vk.waitForFences (engineLogicalDevice engineData) fences True maxBound
+    (V.singleton $ frameRenderFence frame)
-  Vk.resetFences (engineLogicalDevice engineData) fences
+    True
+    maxBound
+  Vk.resetFences (engineLogicalDevice engineData) (V.singleton $ frameRenderFence frame)
 
   (imageResult, index) <-
     Khr.acquireNextImageKHR
       (engineLogicalDevice engineData)
       (engineSwapchain engineData)
       maxBound
-      (engineImageAvailableSemaphore engineData)
+      (frameRenderSemaphore frame)
       Vk.NULL_HANDLE
 
   unless (imageResult == Vk.SUCCESS) $
@@ -53,13 +50,13 @@ drawFrame engineData = do
 
   -- liftIO $ putStrLn "resetting command buffer"
   Vk.resetCommandBuffer
-    (engineCommandBuffers engineData V.! fromIntegral index) (Vk.CommandBufferResetFlagBits 0)
+    (frameMainCommandBuffer frame) (Vk.CommandBufferResetFlagBits 0)
 
   matLibrary <- (liftIO . STM.atomically. STM.readTMVar) =<< asks materialLibrary
 
   -- liftIO $ putStrLn "recording command buffer"
   recordCommandBuffer
-    (engineCommandBuffers engineData V.! fromIntegral index)
+    (frameMainCommandBuffer frame)
     (engineRenderPass engineData)
     (engineFramebuffers engineData V.! fromIntegral index)
     (engineWindowDimensions engineData)
@@ -68,23 +65,23 @@ drawFrame engineData = do
 
   let submitInfo = Vk.zero
         { Vk.waitSemaphores =
-          V.singleton $ engineImageAvailableSemaphore engineData
+          V.singleton $ frameRenderSemaphore frame
         , Vk.waitDstStageMask =
           V.singleton Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
         , Vk.commandBuffers =
-          V.singleton (Vk.commandBufferHandle $ engineCommandBuffers engineData V.! fromIntegral index)
+          V.singleton (Vk.commandBufferHandle $ frameMainCommandBuffer frame)
         , Vk.signalSemaphores =
-          V.singleton $ engineRenderFinishedSemaphore engineData
+          V.singleton $ framePresentSemaphore frame
         }
 
   -- liftIO $ putStrLn "submitting to queue"
   Vk.queueSubmit
     (engineQueue engineData)
     (V.singleton (Vk.SomeStruct submitInfo))
-    (engineInFlightFence engineData)
+    (frameRenderFence frame)
 
   let presentInfo = Vk.zero
-        { Khr.waitSemaphores = V.singleton $ engineRenderFinishedSemaphore engineData
+        { Khr.waitSemaphores = V.singleton $ framePresentSemaphore frame
         , Khr.swapchains = V.singleton $ engineSwapchain engineData
         , Khr.imageIndices = V.singleton index
         }

src/Init.hs

@@ -24,10 +24,10 @@ import Instance
 import Devices
 import GraphicsPipeline
 import Framebuffers
-import CommandBuffer
 import Memory
 import Types
 import Mesh
+import CommandBuffer
 
 initEngine
   :: Render EngineData
@@ -101,11 +101,7 @@ initVulkan window = do
 
   frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews depthImageView dimensions
 
-  (commandPool, graphicsQueue) <- createCommandPool vulkanPhysicalDevice vulkanLogicalDevice
+  (frames, queue) <- createFrames vulkanPhysicalDevice vulkanLogicalDevice
-  commandBuffer <- createCommandBuffer vulkanLogicalDevice commandPool (length frameBuffers)
-
-  (imageAvailableSemaphore, renderFinishedSemaphore, inFlightFence) <-
-    createSyncObjects vulkanLogicalDevice
 
   loadMeshes allocator
 
@@ -118,18 +114,15 @@ initVulkan window = do
     vulkanLogicalDevice
     vulkanInstance
     swapchain
-    graphicsQueue
+    queue
-    commandBuffer
     frameBuffers
     meshLayout
     renderPass
-    inFlightFence
-    imageAvailableSemaphore
-    renderFinishedSemaphore
     allocator
     depthImageView
     depthAllocatedImage
     Vk.FORMAT_D32_SFLOAT
+    frames
 
 initScene :: (MonadReader ReadState m, MonadIO m) => m ()
 initScene = do

src/Main.hs

@@ -27,6 +27,7 @@ main = do
   renderablesContainer <- STM.newTMVarIO (V.empty)
   meshMap <- STM.newTMVarIO (M.empty)
   materialMap <- STM.newTMVarIO (M.empty)
+  frameNumber <- STM.newTMVarIO 0
   let initState = ReadState
         { renderables = renderablesContainer
         , meshLibrary = meshMap
@@ -45,8 +46,12 @@ main = do
       (liftIO $ STM.atomically $ STM.readTMVar quit
         )
       ( do
+        number <- liftIO $ STM.atomically $ do
+          number <- STM.readTMVar frameNumber
+          void $ STM.swapTMVar frameNumber (succ number)
+          return number
         -- draw
-        drawFrame engineData
+        drawFrame engineData number
         -- poll events
         evs <- liftIO SDL.pollEvents
         -- flip abort condition on window close

src/Types.hs

@@ -31,17 +31,14 @@ data EngineData = EngineData
   , engineInstance                :: Vk.Instance
   , engineSwapchain               :: Vk.SwapchainKHR
   , engineQueue                   :: Vk.Queue
-  , engineCommandBuffers          :: V.Vector Vk.CommandBuffer
   , engineFramebuffers            :: V.Vector Vk.Framebuffer
   , meshPipelineLayout            :: Vk.PipelineLayout
   , engineRenderPass              :: Vk.RenderPass
-  , engineInFlightFence           :: Vk.Fence
-  , engineImageAvailableSemaphore :: Vk.Semaphore
-  , engineRenderFinishedSemaphore :: Vk.Semaphore
   , engineAllocator               :: VMA.Allocator
   , engineDepthImageView          :: Vk.ImageView
   , engineDepthImage              :: AllocatedImage
   , engineDepthFormat             :: Vk.Format
+  , engineFrames                  :: V.Vector FrameData
   } 
 
 data AllocatedBuffer = AllocatedBuffer
@@ -180,3 +177,12 @@ type Render a = RenderReader ReadState ResIO a
 
 runRender :: ReadState -> Render a -> IO a
 runRender rd actions = runResourceT $ flip runReaderT rd $ runRenderInner actions
+
+data FrameData = FrameData
+  { framePresentSemaphore  :: Vk.Semaphore
+  , frameRenderSemaphore   :: Vk.Semaphore
+  , frameRenderFence       :: Vk.Fence
+  , frameCommandPool       :: Vk.CommandPool
+  , frameMainCommandBuffer :: Vk.CommandBuffer
+  }
+  deriving (Show)

vulkan-tutorial.cabal

@@ -35,6 +35,7 @@ executable vulkan-tutorial
                       Mesh
                       Image
                       Types
+                      Util
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions: