{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} module CommandBuffer where import qualified Control.Concurrent.STM as STM import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Resource import qualified Data.Map.Strict as M import qualified Data.Vector as V import Foreign import Foreign.C.Types (CInt) import Linear import qualified Vulkan as Vk import qualified Vulkan.CStruct.Extends as Vk import qualified Vulkan.Zero as Vk import qualified VulkanMemoryAllocator as VMA -- internal imports import Devices import Types import Memory import Util frameOverlap :: Int frameOverlap = 2 createFrames :: (MonadResource m, MonadFail m) => Vk.PhysicalDevice -> Vk.Device -> VMA.Allocator -> Vk.DescriptorPool -> Vk.DescriptorSetLayout -> m (V.Vector FrameData, Vk.Queue) createFrames physicalDevice logicalDevice allocator descriptorPool setLayout = do queueFamilyIndex <- getQueueFamily physicalDevice Vk.QUEUE_GRAPHICS_BIT deviceProperties <- Vk.getPhysicalDeviceProperties physicalDevice let poolCreateInfo = Vk.zero { Vk.flags = Vk.COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT , Vk.queueFamilyIndex = queueFamilyIndex } :: Vk.CommandPoolCreateInfo graphicsQueue <- Vk.getDeviceQueue logicalDevice queueFamilyIndex 0 frames <- V.mapM (\index -> do commandPool <- snd <$> allocate (Vk.createCommandPool logicalDevice poolCreateInfo Nothing) (\commandPool -> do putStrLn "destroying command pool" Vk.destroyCommandPool logicalDevice commandPool Nothing ) let commandBufferAllocationInfo = Vk.zero { Vk.commandPool = commandPool , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY , Vk.commandBufferCount = 1 } commandBuffer <- Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo let semaphoreCreateInfo = Vk.zero 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 ) cameraBuffer <- createAllocatedBuffer allocator (sizeOf (GPUCameraData identity identity identity)) Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT VMA.MEMORY_USAGE_CPU_TO_GPU let allocationInfo = Vk.zero { Vk.descriptorPool = descriptorPool , Vk.setLayouts = V.singleton setLayout } globalDescriptor <- Vk.allocateDescriptorSets logicalDevice allocationInfo let cameraInfo = Vk.zero { Vk.buffer = allocatedBuffer cameraBuffer , Vk.offset = 0 , Vk.range = fromIntegral $ sizeOf (GPUCameraData identity identity identity) } :: Vk.DescriptorBufferInfo sceneInfo = Vk.zero { Vk.buffer = allocatedBuffer cameraBuffer , Vk.offset = padUniformBufferSize (fromIntegral $ sizeOf (undefinedGPUSceneData) * fromIntegral index) deviceProperties , Vk.range = fromIntegral $ sizeOf (undefinedGPUSceneData) } :: Vk.DescriptorBufferInfo cameraWrite = writeDescriptorBuffer Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER (V.head globalDescriptor) cameraInfo 0 sceneWrite = writeDescriptorBuffer Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER (V.head globalDescriptor) sceneInfo 1 setWrites = V.fromList [ cameraWrite , sceneWrite ] Vk.updateDescriptorSets logicalDevice setWrites V.empty return FrameData { framePresentSemaphore = presentSemaphore , frameRenderSemaphore = renderSemaphore , frameRenderFence = renderFence , frameCommandPool = commandPool , frameMainCommandBuffer = V.head commandBuffer , frameCameraBuffer = cameraBuffer , frameGlobalDescriptor = V.head globalDescriptor } ) (V.fromList [1 .. frameOverlap]) return (frames, graphicsQueue) recordCommandBuffer :: (MonadResource m, MonadReader ReadState m, MonadIO m) => Vk.CommandBuffer -> Vk.RenderPass -> Vk.Framebuffer -> V2 CInt -> Vk.Pipeline -> Vk.PipelineLayout -> VMA.Allocator -> GPUSceneData -> AllocatedBuffer -> Vk.PhysicalDeviceProperties -> FrameData -> Int -> m () recordCommandBuffer commandBuffer renderPass frameBuffer (V2 width height) graphicsPipeline meshLayout allocator sceneParameters sceneParameterBuffer deviceProps frame frameNumber = do let commandBufferBeginInfo = Vk.zero { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT , Vk.inheritanceInfo = Nothing } Vk.beginCommandBuffer commandBuffer commandBufferBeginInfo let renderPassInfo = Vk.zero { Vk.renderPass = renderPass , Vk.framebuffer = frameBuffer , Vk.renderArea = Vk.Rect2D { offset = Vk.Offset2D { Vk.x = 0 , Vk.y = 0 } , extent = Vk.Extent2D { Vk.width = fromIntegral width , Vk.height = fromIntegral height } } , Vk.clearValues = V.fromList [ Vk.Color (Vk.Float32 0 0 0 1), Vk.DepthStencil (Vk.ClearDepthStencilValue 1 0)] } Vk.cmdBeginRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS graphicsPipeline let viewport = Vk.zero { Vk.x = 0 , Vk.y = 0 , Vk.width = fromIntegral width , Vk.height = fromIntegral height , Vk.minDepth = 0 , Vk.maxDepth = 1 } scissor = Vk.Rect2D { Vk.offset = Vk.Offset2D { Vk.x = 0 , Vk.y = 0 } , Vk.extent = Vk.Extent2D { Vk.width = fromIntegral width , Vk.height = fromIntegral height } } Vk.cmdSetViewport commandBuffer 0 (V.singleton viewport) Vk.cmdSetScissor commandBuffer 0 (V.singleton scissor) let framed = fromIntegral frameNumber / 120 ambient = V4 (sin framed) 0 (cos framed) 1 frameIndex = frameNumber `mod` frameOverlap scenePointer <- VMA.mapMemory allocator (bufferAllocation sceneParameterBuffer) liftIO $ poke (castPtr scenePointer `plusPtr` (fromIntegral $ padUniformBufferSize (fromIntegral $ sizeOf (undefinedGPUSceneData)) deviceProps * fromIntegral frameIndex)) (sceneParameters { ambientColor = ambient } ) VMA.unmapMemory allocator (bufferAllocation sceneParameterBuffer) renderObjects <- (liftIO . STM.atomically . STM.readTMVar) =<< asks renderables meshMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary materialMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks materialLibrary V.mapM_ (\(RenderObject meshID materialID modelMatrix) -> do let camPosition = V3 (-10 * sin (fromIntegral frameNumber / 90)) (-2) (-10 * cos (fromIntegral frameNumber / 90)) camCenter = V3 0 0 0 camUp = V3 0 1 0 camView = lookAt camPosition camCenter camUp camProjection = perspective (pi/4) (fromIntegral width / fromIntegral height) 0.1 200 cameraData = GPUCameraData { view = transpose camView , projection = transpose camProjection , viewProjection = transpose $ camProjection !*! camView } -- pvm = projection !*! view !*! modelMatrix constants = MeshPushConstants { meshPushData = V4 0 0 0 0 , meshRenderMatrix = transpose modelMatrix } mesh = meshMap M.! meshID material = materialMap M.! materialID memoryPointer <- VMA.mapMemory allocator (bufferAllocation $ frameCameraBuffer frame) liftIO $ poke (castPtr memoryPointer) cameraData VMA.unmapMemory allocator (bufferAllocation $ frameCameraBuffer frame) Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS (materialPipeline material) Vk.cmdBindDescriptorSets commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS (materialPipelineLayout material) 0 (V.singleton $ frameGlobalDescriptor frame) V.empty dataPointer <- liftIO (castPtr <$> new constants) Vk.cmdPushConstants commandBuffer (materialPipelineLayout material) Vk.SHADER_STAGE_VERTEX_BIT 0 (fromIntegral $ sizeOf constants) dataPointer Vk.cmdBindVertexBuffers commandBuffer 0 (V.fromList [ allocatedBuffer $ meshBuffer mesh ]) (V.fromList [ 0 ]) Vk.cmdDraw commandBuffer (fromIntegral $ V.length $ meshVertices mesh) 1 0 0 ) renderObjects Vk.cmdEndRenderPass commandBuffer Vk.endCommandBuffer commandBuffer