optimisation

src/CommandBuffer.hs

@@ -21,6 +21,7 @@ import qualified VulkanMemoryAllocator as VMA
 -- internal imports
 
 import Devices
+import Sync
 import Types
 import Memory
 import Util

src/Init.hs

@@ -30,6 +30,7 @@ import Memory
 import Types
 import Mesh
 import CommandBuffer
+import Sync
 import Util
 
 initEngine
@@ -89,6 +90,8 @@ initVulkan window = do
   vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
   (vulkanLogicalDevice, surfaceFormats) <- createLogicalDevice vulkanPhysicalDevice vulkanSurface
 
+  uploadContext <- initSyncStructures vulkanPhysicalDevice vulkanLogicalDevice
+
   (descriptorSetLayout1, descriptorSetLayout2, descriptorPool) <- initDescriptors vulkanLogicalDevice
 
   allocator <- initAllocator vulkanPhysicalDevice vulkanLogicalDevice vulkanInstance
@@ -118,9 +121,16 @@ initVulkan window = do
 
   frameBuffers <- createFramebuffer vulkanLogicalDevice renderPass imageViews depthImageView dimensions
 
-  (frames, queue) <- createFrames vulkanPhysicalDevice vulkanLogicalDevice allocator descriptorPool descriptorSetLayout1 descriptorSetLayout2
+  (frames, queue) <-
+    createFrames
+      vulkanPhysicalDevice
+      vulkanLogicalDevice
+      allocator
+      descriptorPool
+      descriptorSetLayout1
+      descriptorSetLayout2
 
-  loadMeshes allocator
+  loadMeshes allocator uploadContext queue vulkanLogicalDevice
 
   initScene
 
@@ -149,6 +159,7 @@ initVulkan window = do
       (V4 0 0 0 0)
       (V4 0 0 0 0)
       )
+    uploadContext
 
 
 initScene :: (MonadReader ReadState m, MonadIO m) => m ()

src/Mesh.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Mesh where
 
 import Codec.Wavefront
@@ -8,7 +9,7 @@ import Codec.Wavefront
 import qualified Control.Concurrent.STM as STM
 import qualified Control.Monad as CM (void)
 import Control.Monad.IO.Class
-import Control.Monad.Reader (asks)
+import Control.Monad.Reader
 import Control.Monad.Trans.Resource
 
 import qualified Data.Map.Strict as M
@@ -25,19 +26,24 @@ import qualified Vulkan.Zero as Vk
 -- internal imports
 
 import Types
+import Sync
 
 loadMeshes
-  :: VMA.Allocator
+  :: (MonadReader ReadState m, MonadResource m, MonadFail m)
-  -> Render ()
+  => VMA.Allocator
-loadMeshes allocator = do
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
+  -> m ()
+loadMeshes allocator uploadContext queue device = do
   let triangle = V.fromList
         [ Vertex (V3 0.5 0.5 0)    (V3 0 0 0) (V4 0 1 0 1)
         , Vertex (V3 (-0.5) 0.5 0) (V3 0 0 0) (V4 0 1 0 1)
         , Vertex (V3 0 (-0.5) 0)   (V3 0 0 0) (V4 0 1 0 1)
         ]
 
-  triMesh <- uploadMesh triangle allocator
+  triMesh <- uploadMesh triangle allocator uploadContext queue device
-  maskMesh <- loadFromObj "./assets/cat_mask_cyberpunk.obj" allocator
+  maskMesh <- loadFromObj "./assets/cat_mask_cyberpunk.obj" allocator uploadContext queue device
 
   meshLib <- asks meshLibrary
 
@@ -52,30 +58,75 @@ uploadMesh
   :: (MonadResource m, MonadFail m)
   => V.Vector Vertex
   -> VMA.Allocator
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
   -> m Mesh
-uploadMesh vertices allocator = do
+uploadMesh vertices allocator uploadContext queue device = do
-  let bufferCreateInfo = Vk.zero
+
-        { Vk.size  = fromIntegral $
+  let bufferSize = fromIntegral $ V.length vertices * sizeOf (undefined :: Vertex)
-          V.length vertices * sizeOf (Vertex (V3 0 0 0) (V3 0 0 0 ) (V4 0 0 0 0))
+      stagingBufferCrateInfo = Vk.zero
-        , Vk.usage = Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT
+        { Vk.size  = bufferSize
+        , Vk.usage = Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
         }
-      allocationCreateInfo = Vk.zero
+      stagingAllocationCreateInfo = Vk.zero
-        { VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
+        { VMA.usage = VMA.MEMORY_USAGE_CPU_ONLY
         } :: VMA.AllocationCreateInfo
-  mesh <- do
+
-      (buffer, bAllocation, bInfo) <- snd <$>
+  (stagingReleaseKey, stagingBuffer) <- do
-        VMA.withBuffer allocator bufferCreateInfo allocationCreateInfo allocate
+    (releaseKey, (buffer, bAllocation, bInfo)) <-
-      return (Mesh vertices (AllocatedBuffer buffer bAllocation bInfo))
+      VMA.withBuffer allocator stagingBufferCrateInfo stagingAllocationCreateInfo allocate
+    return (releaseKey, AllocatedBuffer
+      { bufferInfo = bInfo
+      , bufferAllocation = bAllocation
+      , allocatedBuffer = buffer
+      })
 
   (dataReleaseKey, dataPtr) <-
-    VMA.withMappedMemory allocator (bufferAllocation $ meshBuffer mesh) allocate
+    VMA.withMappedMemory allocator (bufferAllocation stagingBuffer) allocate
 
-  liftIO $ mapM_ (\(idx, vertex) ->
+  liftIO $ V.mapM_ (\(idx, vertex) ->
-    poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex
+    poke
+      (castPtr dataPtr `plusPtr` (idx * sizeOf vertex))
+      vertex
     )
-    (zip [0..] (V.toList vertices))
+    (V.zip
+      (V.fromList [0..])
+      vertices
+      )
 
-  release dataReleaseKey
+  liftIO $ release dataReleaseKey
+
+  let vertexBufferCreateInfo = Vk.zero
+        { Vk.size = bufferSize
+        , Vk.usage = Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT .|. Vk.BUFFER_USAGE_TRANSFER_DST_BIT
+        }
+      allocationCreateInfo = Vk.zero
+        { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
+        } :: VMA.AllocationCreateInfo
+
+  mesh <- do
+    (buffer, bAllocation, bInfo) <- snd <$>
+      VMA.withBuffer allocator vertexBufferCreateInfo allocationCreateInfo allocate
+    return $ Mesh
+      { meshVertices = vertices
+      , meshBuffer = AllocatedBuffer
+        { bufferInfo = bInfo
+        , bufferAllocation = bAllocation
+        , allocatedBuffer = buffer
+        }
+      }
+
+  immediateSubmit uploadContext queue device$ \cmd -> do
+    let copy = V.singleton $ Vk.BufferCopy
+          { size = bufferSize
+          , dstOffset = 0
+          , srcOffset = 0
+          }
+
+    Vk.cmdCopyBuffer cmd (allocatedBuffer stagingBuffer) (allocatedBuffer $ meshBuffer mesh) copy
+
+  release stagingReleaseKey
 
   return mesh
 
@@ -83,15 +134,18 @@ loadFromObj
   :: (MonadResource m, MonadFail m)
   => FilePath
   -> VMA.Allocator
+  -> UploadContext
+  -> Vk.Queue
+  -> Vk.Device
   -> m Mesh
-loadFromObj filepath vma = do
+loadFromObj filepath vma uploadContext queue device = do
   eitherObj <- liftIO $ fromFile filepath
   case eitherObj of
     Left err ->
       error ("loadFromObj:  loading mesh data: " <> err)
     Right obj -> do
       let vertices = digestFaces (objFaces obj) (objLocations obj)
-      uploadMesh vertices vma
+      uploadMesh vertices vma uploadContext queue device
   where
     digestFaces :: V.Vector (Element Face) -> V.Vector Location -> V.Vector Vertex
     digestFaces faces locations =

src/Sync.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Sync where
+
+import Control.Monad.Trans.Resource
+import Data.Bits (bit)
+import qualified Data.Vector as V
+import qualified Vulkan as Vk
+import qualified Vulkan.Zero as Vk
+
+-- internal imports
+
+import Control.Monad.Reader
+import Devices
+import Types
+import Util
+
+initSyncStructures
+  :: (MonadResource m)
+  => Vk.PhysicalDevice
+  -> Vk.Device
+  -> m UploadContext
+initSyncStructures physicalDevice logicalDevice = do
+
+  let fenceCreateInfo = Vk.zero
+
+  syncFence <- snd <$>
+    Vk.withFence logicalDevice fenceCreateInfo Nothing allocate
+
+  queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT
+
+  let uploadCommandPoolCreateInfo = Vk.zero
+        { Vk.queueFamilyIndex = queueFamilyIndex
+        } :: Vk.CommandPoolCreateInfo
+
+  syncCommandPool <- snd <$>
+    Vk.withCommandPool logicalDevice uploadCommandPoolCreateInfo Nothing allocate
+
+  let cmdBufAllocInfo = Vk.zero
+        { Vk.commandPool        = syncCommandPool
+        , Vk.commandBufferCount = 1
+        }
+
+  syncCommandBuffer <- V.head . snd <$> Vk.withCommandBuffers logicalDevice cmdBufAllocInfo allocate
+
+  return $ UploadContext
+    { uploadFence = syncFence
+    , uploadCommandBuffer = syncCommandBuffer
+    , uploadCommandPool = syncCommandPool
+    }
+
+immediateSubmit
+  :: (MonadIO m)
+  => UploadContext
+  -> Vk.Queue
+  -> Vk.Device
+  -> (Vk.CommandBuffer -> m ())
+  -> m ()
+immediateSubmit uploadContext queue device func = do
+
+  let cmdBegin = beginCommandBuffer Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
+
+  Vk.useCommandBuffer
+    (uploadCommandBuffer uploadContext)
+    cmdBegin
+    (func (uploadCommandBuffer uploadContext))
+
+  let submitInfo = createSubmitInfo (uploadCommandBuffer uploadContext)
+
+  Vk.queueSubmit queue submitInfo (uploadFence uploadContext)
+
+  void $ Vk.waitForFences device (V.singleton $ uploadFence uploadContext) True maxBound
+  Vk.resetFences device (V.singleton $ uploadFence uploadContext)
+
+  Vk.resetCommandPool device (uploadCommandPool uploadContext) (bit 0)

src/Types.hs

@@ -24,24 +24,25 @@ data ShaderContainer = ShaderContainer
   deriving (Show)
 
 data EngineData = EngineData
-  { engineWindow                   :: SDL.Window
+  { engineWindow           :: SDL.Window
-  , engineWindowDimensions         :: V2 CInt
+  , engineWindowDimensions :: V2 CInt
-  , enginePhysicalDevice           :: Vk.PhysicalDevice
+  , enginePhysicalDevice   :: Vk.PhysicalDevice
-  , engineLogicalDevice            :: Vk.Device
+  , engineLogicalDevice    :: Vk.Device
-  , engineInstance                 :: Vk.Instance
+  , engineInstance         :: Vk.Instance
-  , engineSwapchain                :: Vk.SwapchainKHR
+  , engineSwapchain        :: Vk.SwapchainKHR
-  , engineQueue                    :: Vk.Queue
+  , engineQueue            :: Vk.Queue
-  , engineFramebuffers             :: V.Vector Vk.Framebuffer
+  , engineFramebuffers     :: V.Vector Vk.Framebuffer
-  , engineRenderPass               :: Vk.RenderPass
+  , engineRenderPass       :: Vk.RenderPass
-  , engineAllocator                :: VMA.Allocator
+  , engineAllocator        :: VMA.Allocator
-  , engineDepthImageView           :: Vk.ImageView
+  , engineDepthImageView   :: Vk.ImageView
-  , engineDepthImage               :: AllocatedImage
+  , engineDepthImage       :: AllocatedImage
-  , engineDepthFormat              :: Vk.Format
+  , engineDepthFormat      :: Vk.Format
-  , engineFrames                   :: V.Vector FrameData
+  , engineFrames           :: V.Vector FrameData
-  , engineGlobalSetLayout          :: Vk.DescriptorSetLayout
+  , engineGlobalSetLayout  :: Vk.DescriptorSetLayout
-  , engineObjectSetLayout          :: Vk.DescriptorSetLayout
+  , engineObjectSetLayout  :: Vk.DescriptorSetLayout
-  , engineDescriptorPool           :: Vk.DescriptorPool
+  , engineDescriptorPool   :: Vk.DescriptorPool
-  , engineSceneParameters          :: GPUSceneData
+  , engineSceneParameters  :: GPUSceneData
+  , engineUploadContext    :: UploadContext
   } 
 
 data AllocatedBuffer = AllocatedBuffer
@@ -60,7 +61,7 @@ data Vertex = Vertex
 
 instance Storable Vertex where
 
-  sizeOf (Vertex position normal color) = sizeOf position + sizeOf normal + sizeOf color
+  sizeOf _ = sizeOf (undefined :: V3 Float) * 2 + sizeOf (undefined :: V4 Float)
 
   peek ptr = do
     pos <- peek (castPtr ptr)
@@ -180,7 +181,8 @@ data ReadState = ReadState
 newtype RenderReader rd m a = RenderReader
   { runRenderInner :: RenderInner rd m a
   }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadReader rd, MonadResource, MonadFail)
+  deriving
+    (Functor, Applicative, Monad, MonadIO, MonadReader rd, MonadResource, MonadFail)
 
 type RenderInner rd m = ReaderT rd m
 
@@ -285,3 +287,10 @@ instance Storable GPUSceneData where
     poke (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDist)) ambCol
     poke (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDist + sizeOf ambCol)) sunDir
     poke (castPtr $ ptr `plusPtr` (sizeOf fogCol + sizeOf fogDist + sizeOf ambCol + sizeOf sunDir)) sunCol
+
+data UploadContext = UploadContext
+  { uploadFence         :: Vk.Fence
+  , uploadCommandPool   :: Vk.CommandPool
+  , uploadCommandBuffer :: Vk.CommandBuffer
+  }
+  deriving (Show)

src/Util.hs

@@ -64,3 +64,19 @@ writeDescriptorBuffer type' dstSet dBufferInfo binding = Vk.SomeStruct $
     , Vk.descriptorType  = type'
     , Vk.bufferInfo      = V.singleton dBufferInfo
     }
+
+beginCommandBuffer
+  :: Vk.CommandBufferUsageFlags
+  -> Vk.CommandBufferBeginInfo '[]
+beginCommandBuffer flags =
+  Vk.zero
+    { Vk.flags = flags
+    }
+
+createSubmitInfo
+  :: Vk.CommandBuffer
+  -> V.Vector (Vk.SomeStruct Vk.SubmitInfo)
+createSubmitInfo cmd = V.singleton $ Vk.SomeStruct $
+  Vk.zero
+    { Vk.commandBuffers = V.singleton (Vk.commandBufferHandle cmd)
+    }

vulkan-tutorial.cabal

@@ -34,6 +34,7 @@ executable vulkan-tutorial
                       Memory
                       Mesh
                       Image
+                      Sync
                       Types
                       Util