From cde6d15245f86a212b175930c7ae44ff767b2d7e Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 29 Apr 2023 02:10:27 +0200 Subject: [PATCH] optimize allocations --- src/CommandBuffer.hs | 283 ++++++++++++++++++++-------------------- src/Devices.hs | 40 ++---- src/Draw.hs | 2 - src/Framebuffers.hs | 7 +- src/GraphicsPipeline.hs | 39 ++---- src/Init.hs | 24 +--- src/Instance.hs | 7 +- src/Main.hs | 22 +--- src/Memory.hs | 8 +- src/Mesh.hs | 18 +-- 10 files changed, 182 insertions(+), 268 deletions(-) diff --git a/src/CommandBuffer.hs b/src/CommandBuffer.hs index 5798b1c..e7858d5 100644 --- a/src/CommandBuffer.hs +++ b/src/CommandBuffer.hs @@ -55,12 +55,8 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj frames <- V.mapM (\_ -> do - commandPool <- snd <$> allocate - (Vk.createCommandPool logicalDevice poolCreateInfo Nothing) - (\commandPool -> do - putStrLn "destroying command pool" - Vk.destroyCommandPool logicalDevice commandPool Nothing - ) + commandPool <- snd <$> + (Vk.withCommandPool logicalDevice poolCreateInfo Nothing allocate) let commandBufferAllocationInfo = Vk.zero { Vk.commandPool = commandPool @@ -68,7 +64,7 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj , Vk.commandBufferCount = 1 } - commandBuffer <- Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo + (_, commandBuffer) <- Vk.withCommandBuffers logicalDevice commandBufferAllocationInfo allocate let semaphoreCreateInfo = Vk.zero fenceCreateInfo = Vk.zero @@ -76,19 +72,11 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj } :: 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 + (snd <$> + Vk.withSemaphore logicalDevice semaphoreCreateInfo Nothing allocate ) + renderFence <- snd <$> + Vk.withFence logicalDevice fenceCreateInfo Nothing allocate cameraBuffer <- createAllocatedBuffer allocator @@ -207,143 +195,158 @@ recordCommandBuffer , Vk.inheritanceInfo = Nothing } - Vk.beginCommandBuffer commandBuffer commandBufferBeginInfo + Vk.useCommandBuffer commandBuffer commandBufferBeginInfo $ do - 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 + 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.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.cmdUseRenderPass commandBuffer renderPassInfo Vk.SUBPASS_CONTENTS_INLINE $ do - Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS graphicsPipeline + liftIO $ + prepareRecording width height commandBuffer renderPass frameBuffer 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 = normalize $ V4 (sin framed) 0 (cos framed) 1 - -- ambient = V4 1 0 1 1 - ambientParams = sceneParameters - { ambientColor = ambient - } - - liftIO $ do - let scenePointer = VMA.mappedData (bufferInfo (frameSceneBuffer frame)) - - liftIO $ poke - (castPtr scenePointer) - ambientParams - - renderObjects <- (liftIO . STM.atomically . STM.readTMVar) =<< asks renderables - meshMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary - - V.mapM_ - (\(index, 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 - - materialMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks materialLibrary - - let cameraData = GPUCameraData - { view = transpose camView - , projection = transpose camProjection - , viewProjection = transpose $ camProjection !*! camView + let framed = fromIntegral frameNumber / 120 + ambient = normalize $ V4 (sin framed) 0 (cos framed) 1 + -- ambient = V4 1 0 1 1 + ambientParams = sceneParameters + { ambientColor = ambient } - constants = MeshPushConstants - { meshPushData = V4 0 0 0 0 - , meshRenderMatrix = transpose modelMatrix - } - mesh = meshMap M.! meshID - material = materialMap M.! materialID + liftIO $ do + let scenePointer = VMA.mappedData (bufferInfo (frameSceneBuffer frame)) - liftIO $ VMA.withMappedMemory - allocator - (bufferAllocation $ frameCameraBuffer frame) - bracket - $ \memoryPointer -> + liftIO $ poke + (castPtr scenePointer) + ambientParams - liftIO $ poke (castPtr memoryPointer) cameraData + renderObjects <- (liftIO . STM.atomically . STM.readTMVar) =<< asks renderables + meshMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks meshLibrary - Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS (materialPipeline material) + V.mapM_ + (\(index, RenderObject meshID materialID modelMatrix) -> do - Vk.cmdBindDescriptorSets - commandBuffer - Vk.PIPELINE_BIND_POINT_GRAPHICS - (materialPipelineLayout material) - 0 - (V.singleton $ frameGlobalDescriptor frame) - V.empty + 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 - Vk.cmdBindDescriptorSets - commandBuffer - Vk.PIPELINE_BIND_POINT_GRAPHICS - (materialPipelineLayout material) - 1 - (V.singleton $ frameObjectDescriptor frame) - V.empty + materialMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks materialLibrary - dataPointer <- liftIO (castPtr <$> new constants) + let cameraData = GPUCameraData + { view = transpose camView + , projection = transpose camProjection + , viewProjection = transpose $ camProjection !*! camView + } - Vk.cmdPushConstants - commandBuffer - (materialPipelineLayout material) - Vk.SHADER_STAGE_VERTEX_BIT - 0 - (fromIntegral $ sizeOf constants) - dataPointer + constants = MeshPushConstants + { meshPushData = V4 0 0 0 0 + , meshRenderMatrix = transpose modelMatrix + } + mesh = meshMap M.! meshID + material = materialMap M.! materialID - Vk.cmdBindVertexBuffers - commandBuffer - 0 - (V.fromList [ allocatedBuffer $ meshBuffer mesh ]) - (V.fromList [ 0 ]) + liftIO $ VMA.withMappedMemory + allocator + (bufferAllocation $ frameCameraBuffer frame) + bracket + $ \memoryPointer -> - Vk.cmdDraw commandBuffer (fromIntegral $ V.length $ meshVertices mesh) 1 0 index - ) - (V.zip - (V.fromList [0 ..]) - renderObjects - ) + liftIO $ poke (castPtr memoryPointer) cameraData - Vk.cmdEndRenderPass commandBuffer + Vk.cmdBindPipeline commandBuffer Vk.PIPELINE_BIND_POINT_GRAPHICS (materialPipeline material) - Vk.endCommandBuffer commandBuffer + Vk.cmdBindDescriptorSets + commandBuffer + Vk.PIPELINE_BIND_POINT_GRAPHICS + (materialPipelineLayout material) + 0 + (V.singleton $ frameGlobalDescriptor frame) + V.empty + + Vk.cmdBindDescriptorSets + commandBuffer + Vk.PIPELINE_BIND_POINT_GRAPHICS + (materialPipelineLayout material) + 1 + (V.singleton $ frameObjectDescriptor 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 index + ) + (V.zip + (V.fromList [0 ..]) + renderObjects + ) + +prepareRecording + :: CInt + -> CInt + -> Vk.CommandBuffer + -> Vk.RenderPass + -> Vk.Framebuffer + -> Vk.Pipeline + -> IO () +prepareRecording width height commandBuffer renderPass frameBuffer graphicsPipeline = do + 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) diff --git a/src/Devices.hs b/src/Devices.hs index da7e241..d28635d 100644 --- a/src/Devices.hs +++ b/src/Devices.hs @@ -106,12 +106,8 @@ createLogicalDevice physDevice surface = do , Vk.enabledExtensionNames = extensionNames } - (_, logDevice) <- allocate - (Vk.createDevice physDevice deviceCreateInfo Nothing) - (\logDevice -> do - putStrLn "destroying logical device" - Vk.destroyDevice logDevice Nothing - ) + (_, logDevice) <- + Vk.withDevice physDevice deviceCreateInfo Nothing allocate (result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface unless (result == Vk.SUCCESS) $ @@ -166,12 +162,8 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator = , Vk.clipped = True } - swapchain <- snd <$> allocate - (Vk.createSwapchainKHR logicalDevice createInfo Nothing) - (\swapchain -> do - putStrLn "destroying swapchain" - Vk.destroySwapchainKHR logicalDevice swapchain Nothing - ) + swapchain <- snd <$> + Vk.withSwapchainKHR logicalDevice createInfo Nothing allocate let depthImageExtent = (\(V2 w h) -> Vk.Extent3D (fromIntegral w) (fromIntegral h) 1) @@ -187,12 +179,8 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator = , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT } - (depthImage, depthAllocation, _) <- snd <$> allocate - (VMA.createImage allocator depthImageInfo depthImageAllocationInfo) - (\(depthImage, depthAllocation, _) -> do - putStrLn "destroying image" - VMA.destroyImage allocator depthImage depthAllocation - ) + (depthImage, depthAllocation, _) <- snd <$> + VMA.withImage allocator depthImageInfo depthImageAllocationInfo allocate let allocatedImage = AllocatedImage depthImage depthAllocation depthImageView = imageviewCreate @@ -200,12 +188,8 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator = Vk.FORMAT_D32_SFLOAT Vk.IMAGE_ASPECT_DEPTH_BIT - depthImageview <- snd <$> allocate - (Vk.createImageView logicalDevice depthImageView Nothing) - (\depthImageview -> do - putStrLn "destroying image view" - Vk.destroyImageView logicalDevice depthImageview Nothing - ) + depthImageview <- snd <$> + Vk.withImageView logicalDevice depthImageView Nothing allocate return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace, depthImageview, allocatedImage) @@ -243,11 +227,7 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do , layerCount = 1 } } - snd <$> allocate - (Vk.createImageView logicalDevice createInfo Nothing) - (\imageView -> do - putStrLn "destroying image view" - Vk.destroyImageView logicalDevice imageView Nothing - ) + snd <$> + Vk.withImageView logicalDevice createInfo Nothing allocate ) handles diff --git a/src/Draw.hs b/src/Draw.hs index 0cc35dd..eaf77fc 100644 --- a/src/Draw.hs +++ b/src/Draw.hs @@ -77,7 +77,6 @@ drawFrame engineData frameNumber = do V.singleton $ framePresentSemaphore frame } - -- liftIO $ putStrLn "submitting to queue" Vk.queueSubmit (engineQueue engineData) (V.singleton (Vk.SomeStruct submitInfo)) @@ -89,7 +88,6 @@ drawFrame engineData frameNumber = do , Khr.imageIndices = V.singleton index } - -- liftIO $ putStrLn "presenting queue" presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo unless (presentResult == Vk.SUCCESS) $ diff --git a/src/Framebuffers.hs b/src/Framebuffers.hs index 157c4fb..c01ea39 100644 --- a/src/Framebuffers.hs +++ b/src/Framebuffers.hs @@ -39,11 +39,6 @@ createFramebuffer let createInfo = framebufferCreateInfo { Vk.attachments = V.fromList [ imageView, depthImageView ] } :: Vk.FramebufferCreateInfo '[] - snd <$> allocate - (Vk.createFramebuffer logicalDevice createInfo Nothing) - (\framebuffer -> do - putStrLn "destroying framebuffer" - Vk.destroyFramebuffer logicalDevice framebuffer Nothing - ) + snd <$> Vk.withFramebuffer logicalDevice createInfo Nothing allocate ) swapchainImageViews diff --git a/src/GraphicsPipeline.hs b/src/GraphicsPipeline.hs index 53b6185..e5b0035 100644 --- a/src/GraphicsPipeline.hs +++ b/src/GraphicsPipeline.hs @@ -49,12 +49,8 @@ loadShader logicalDevice shaderPath stage = do { Vk.code = shader } - snd <$> allocate - (Vk.createShaderModule logicalDevice createInfo Nothing) - (\shaderModule -> do - putStrLn "destroying shader module" - Vk.destroyShaderModule logicalDevice shaderModule Nothing - ) + snd <$> + Vk.withShaderModule logicalDevice createInfo Nothing allocate createRenderPass :: (MonadResource m) @@ -126,12 +122,8 @@ createRenderPass , Vk.dependencies = V.fromList [ subpassDependency, subpassDepthDependency ] } :: Vk.RenderPassCreateInfo '[] - snd <$> allocate - (Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing) - (\renderPass -> do - putStrLn "destroying render pass" - Vk.destroyRenderPass logicalDevice renderPass Nothing - ) + snd <$> + Vk.withRenderPass logicalDevice renderPassCreateInfo Nothing allocate createShaderStageCreateInfo :: Vk.ShaderStageFlagBits @@ -300,25 +292,18 @@ createGraphicsPipelines , Vk.basePipelineIndex = -1 } - pipeline <- snd <$> allocate + pipeline <- (do - (result, pipelines) <- Vk.createGraphicsPipelines + (result, pipelines) <- snd <$> Vk.withGraphicsPipelines logicalDevice Vk.NULL_HANDLE (V.singleton (Vk.SomeStruct pipelineCreateInfo)) Nothing + allocate unless (result == Vk.SUCCESS) $ error "createGraphicsPipelines: Failed creating pipelines" return pipelines ) - (\pipelines -> do - V.mapM_ - (\pipeline -> do - putStrLn "destroying pipeline" - Vk.destroyPipeline logicalDevice pipeline Nothing - ) - pipelines - ) let material = Material (V.head pipeline) pipelineLayout matLibraryTMVar <- asks materialLibrary matLibrary <- liftIO $ STM.atomically $ STM.readTMVar matLibraryTMVar @@ -333,7 +318,7 @@ createMeshPipelineLayout createMeshPipelineLayout logicalDevice layouts = do let pushConstantRange = Vk.zero { Vk.offset = 0 - , Vk.size = fromIntegral (sizeOf (undefinedMeshPushConstants)) + , Vk.size = fromIntegral (sizeOf undefinedMeshPushConstants) , Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT } pipelineLayoutCreateInfo = Vk.zero @@ -341,9 +326,5 @@ createMeshPipelineLayout logicalDevice layouts = do , Vk.setLayouts = layouts } - snd <$> allocate - (Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing) - (\pipelineLayout -> do - putStrLn "destroying pipeline layout" - Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing - ) + snd <$> + Vk.withPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing allocate diff --git a/src/Init.hs b/src/Init.hs index 1234091..69fc88d 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -229,25 +229,13 @@ initDescriptors device = do ] } - (_, descriptorSetLayout1) <- allocate - (Vk.createDescriptorSetLayout device setInfo Nothing) - (\descriptorLayout -> do - putStrLn "destroying descriptor layout" - Vk.destroyDescriptorSetLayout device descriptorLayout Nothing - ) + (_, descriptorSetLayout1) <- + Vk.withDescriptorSetLayout device setInfo Nothing allocate - (_, descriptorSetLayout2) <- allocate - (Vk.createDescriptorSetLayout device setInfo2 Nothing) - (\descriptorLayout -> do - putStrLn "destroying descriptor layout" - Vk.destroyDescriptorSetLayout device descriptorLayout Nothing - ) + (_, descriptorSetLayout2) <- + Vk.withDescriptorSetLayout device setInfo2 Nothing allocate - (_, descriptorPool) <- allocate - (Vk.createDescriptorPool device poolInfo Nothing) - (\descriptorPoolInfo -> do - putStrLn "destroying descriptor pool" - Vk.destroyDescriptorPool device descriptorPoolInfo Nothing - ) + (_, descriptorPool) <- + Vk.withDescriptorPool device poolInfo Nothing allocate return (descriptorSetLayout1, descriptorSetLayout2, descriptorPool) diff --git a/src/Instance.hs b/src/Instance.hs index 8694c3c..a23e048 100644 --- a/src/Instance.hs +++ b/src/Instance.hs @@ -32,11 +32,6 @@ createInstance window = do , Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation" } - (_, inst) <- allocate - (Vk.createInstance createInfo Nothing) - (\inst -> do - putStrLn "destroying instance" - Vk.destroyInstance inst Nothing - ) + (_, inst) <- Vk.withInstance createInfo Nothing allocate return inst diff --git a/src/Main.hs b/src/Main.hs index 9ba1223..8995dcf 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -80,12 +80,8 @@ createBufferView logicalDevice = do Vk.BUFFER_USAGE_UNIFORM_TEXEL_BUFFER_BIT , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE } - buffer <- snd <$> allocate - (Vk.createBuffer logicalDevice bufferCreateInfo Nothing) - (\buffer -> do - putStrLn "destroying buffer" - Vk.destroyBuffer logicalDevice buffer Nothing - ) + buffer <- snd <$> + (Vk.withBuffer logicalDevice bufferCreateInfo Nothing allocate) let bufferViewCreateInfo = Vk.zero { Vk.buffer = buffer @@ -94,12 +90,7 @@ createBufferView logicalDevice = do , Vk.range = Vk.WHOLE_SIZE } - allocate - (Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing) - (\bufferView -> do - putStrLn "destroying bufferView" - Vk.destroyBufferView logicalDevice bufferView Nothing - ) + Vk.withBufferView logicalDevice bufferViewCreateInfo Nothing allocate allocateMemory :: (MonadResource m) @@ -114,9 +105,4 @@ allocateMemory logicalDevice buffer = do , Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String) } - allocate - (Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing) - (\memory -> do - putStrLn "Freeing memory" - Vk.freeMemory logicalDevice memory Nothing - ) + Vk.withMemory logicalDevice memoryAllocateInfo Nothing allocate diff --git a/src/Memory.hs b/src/Memory.hs index 8da6509..eefab17 100644 --- a/src/Memory.hs +++ b/src/Memory.hs @@ -68,11 +68,7 @@ createAllocatedBuffer allocator allocationSize usage memoryUsage = do , VMA.preferredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT } :: VMA.AllocationCreateInfo - (_, (buffer, newAllocation, info)) <- allocate - (VMA.createBuffer allocator bufferCreateInfo vmaAllocationInfo) - (\(buffer, newAllocation, _) -> do - putStrLn "destroying buffer" - VMA.destroyBuffer allocator buffer newAllocation - ) + (_, (buffer, newAllocation, info)) <- + VMA.withBuffer allocator bufferCreateInfo vmaAllocationInfo allocate return $ AllocatedBuffer buffer newAllocation info diff --git a/src/Mesh.hs b/src/Mesh.hs index ef311e4..f6cf743 100644 --- a/src/Mesh.hs +++ b/src/Mesh.hs @@ -62,21 +62,13 @@ uploadMesh vertices allocator = do allocationCreateInfo = Vk.zero { VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU } :: VMA.AllocationCreateInfo - (_, mesh) <- allocate - (do - (buffer, bAllocation, bInfo) <- VMA.createBuffer allocator bufferCreateInfo allocationCreateInfo + mesh <- do + (buffer, bAllocation, bInfo) <- snd <$> + VMA.withBuffer allocator bufferCreateInfo allocationCreateInfo allocate return (Mesh vertices (AllocatedBuffer buffer bAllocation bInfo)) - ) - (\(Mesh _ (AllocatedBuffer buffer bAllocation _)) -> do - putStrLn "destroying mesh" - VMA.destroyBuffer allocator buffer bAllocation - ) - (dataReleaseKey, dataPtr) <- allocate - (VMA.mapMemory allocator (bufferAllocation $ meshBuffer mesh)) - (\_ -> do - VMA.unmapMemory allocator (bufferAllocation $ meshBuffer mesh) - ) + (dataReleaseKey, dataPtr) <- + VMA.withMappedMemory allocator (bufferAllocation $ meshBuffer mesh) allocate liftIO $ mapM_ (\(idx, vertex) -> poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex