optimize allocations

This commit is contained in:
nek0 2023-04-29 02:10:27 +02:00
parent 744a8ddc55
commit cde6d15245
10 changed files with 182 additions and 268 deletions

View file

@ -55,12 +55,8 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj
frames <- V.mapM frames <- V.mapM
(\_ -> do (\_ -> do
commandPool <- snd <$> allocate commandPool <- snd <$>
(Vk.createCommandPool logicalDevice poolCreateInfo Nothing) (Vk.withCommandPool logicalDevice poolCreateInfo Nothing allocate)
(\commandPool -> do
putStrLn "destroying command pool"
Vk.destroyCommandPool logicalDevice commandPool Nothing
)
let commandBufferAllocationInfo = Vk.zero let commandBufferAllocationInfo = Vk.zero
{ Vk.commandPool = commandPool { Vk.commandPool = commandPool
@ -68,7 +64,7 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj
, Vk.commandBufferCount = 1 , Vk.commandBufferCount = 1
} }
commandBuffer <- Vk.allocateCommandBuffers logicalDevice commandBufferAllocationInfo (_, commandBuffer) <- Vk.withCommandBuffers logicalDevice commandBufferAllocationInfo allocate
let semaphoreCreateInfo = Vk.zero let semaphoreCreateInfo = Vk.zero
fenceCreateInfo = Vk.zero fenceCreateInfo = Vk.zero
@ -76,19 +72,11 @@ createFrames physicalDevice logicalDevice allocator descriptorPool setLayout obj
} :: Vk.FenceCreateInfo '[] } :: Vk.FenceCreateInfo '[]
[presentSemaphore, renderSemaphore] <- replicateM 2 [presentSemaphore, renderSemaphore] <- replicateM 2
(snd <$> allocate (snd <$>
(Vk.createSemaphore logicalDevice semaphoreCreateInfo Nothing) Vk.withSemaphore logicalDevice semaphoreCreateInfo Nothing allocate
(\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
) )
renderFence <- snd <$>
Vk.withFence logicalDevice fenceCreateInfo Nothing allocate
cameraBuffer <- createAllocatedBuffer cameraBuffer <- createAllocatedBuffer
allocator allocator
@ -207,143 +195,158 @@ recordCommandBuffer
, Vk.inheritanceInfo = Nothing , Vk.inheritanceInfo = Nothing
} }
Vk.beginCommandBuffer commandBuffer commandBufferBeginInfo Vk.useCommandBuffer commandBuffer commandBufferBeginInfo $ do
let renderPassInfo = Vk.zero let renderPassInfo = Vk.zero
{ Vk.renderPass = renderPass { Vk.renderPass = renderPass
, Vk.framebuffer = frameBuffer , Vk.framebuffer = frameBuffer
, Vk.renderArea = Vk.Rect2D , Vk.renderArea = Vk.Rect2D
{ offset = Vk.Offset2D { offset = Vk.Offset2D
{ Vk.x = 0 { Vk.x = 0
, Vk.y = 0 , Vk.y = 0
} }
, extent = Vk.Extent2D , extent = Vk.Extent2D
{ Vk.width = fromIntegral width { Vk.width = fromIntegral width
, Vk.height = fromIntegral height , 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 let framed = fromIntegral frameNumber / 120
{ Vk.x = 0 ambient = normalize $ V4 (sin framed) 0 (cos framed) 1
, Vk.y = 0 -- ambient = V4 1 0 1 1
, Vk.width = fromIntegral width ambientParams = sceneParameters
, Vk.height = fromIntegral height { ambientColor = ambient
, 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
} }
constants = MeshPushConstants liftIO $ do
{ meshPushData = V4 0 0 0 0 let scenePointer = VMA.mappedData (bufferInfo (frameSceneBuffer frame))
, meshRenderMatrix = transpose modelMatrix
}
mesh = meshMap M.! meshID
material = materialMap M.! materialID
liftIO $ VMA.withMappedMemory liftIO $ poke
allocator (castPtr scenePointer)
(bufferAllocation $ frameCameraBuffer frame) ambientParams
bracket
$ \memoryPointer ->
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 let camPosition = V3
commandBuffer (-10 * sin (fromIntegral frameNumber / 90))
Vk.PIPELINE_BIND_POINT_GRAPHICS (-2)
(materialPipelineLayout material) (-10 * cos (fromIntegral frameNumber / 90))
0 camCenter = V3 0 0 0
(V.singleton $ frameGlobalDescriptor frame) camUp = V3 0 1 0
V.empty camView = lookAt camPosition camCenter camUp
camProjection = perspective
(pi/4)
(fromIntegral width / fromIntegral height)
0.1
200
Vk.cmdBindDescriptorSets materialMap <- (liftIO . STM.atomically . STM.readTMVar) =<< asks materialLibrary
commandBuffer
Vk.PIPELINE_BIND_POINT_GRAPHICS
(materialPipelineLayout material)
1
(V.singleton $ frameObjectDescriptor frame)
V.empty
dataPointer <- liftIO (castPtr <$> new constants) let cameraData = GPUCameraData
{ view = transpose camView
, projection = transpose camProjection
, viewProjection = transpose $ camProjection !*! camView
}
Vk.cmdPushConstants constants = MeshPushConstants
commandBuffer { meshPushData = V4 0 0 0 0
(materialPipelineLayout material) , meshRenderMatrix = transpose modelMatrix
Vk.SHADER_STAGE_VERTEX_BIT }
0 mesh = meshMap M.! meshID
(fromIntegral $ sizeOf constants) material = materialMap M.! materialID
dataPointer
Vk.cmdBindVertexBuffers liftIO $ VMA.withMappedMemory
commandBuffer allocator
0 (bufferAllocation $ frameCameraBuffer frame)
(V.fromList [ allocatedBuffer $ meshBuffer mesh ]) bracket
(V.fromList [ 0 ]) $ \memoryPointer ->
Vk.cmdDraw commandBuffer (fromIntegral $ V.length $ meshVertices mesh) 1 0 index liftIO $ poke (castPtr memoryPointer) cameraData
)
(V.zip
(V.fromList [0 ..])
renderObjects
)
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)

View file

@ -106,12 +106,8 @@ createLogicalDevice physDevice surface = do
, Vk.enabledExtensionNames = extensionNames , Vk.enabledExtensionNames = extensionNames
} }
(_, logDevice) <- allocate (_, logDevice) <-
(Vk.createDevice physDevice deviceCreateInfo Nothing) Vk.withDevice physDevice deviceCreateInfo Nothing allocate
(\logDevice -> do
putStrLn "destroying logical device"
Vk.destroyDevice logDevice Nothing
)
(result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface (result, formats) <- Vk.getPhysicalDeviceSurfaceFormatsKHR physDevice surface
unless (result == Vk.SUCCESS) $ unless (result == Vk.SUCCESS) $
@ -166,12 +162,8 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator =
, Vk.clipped = True , Vk.clipped = True
} }
swapchain <- snd <$> allocate swapchain <- snd <$>
(Vk.createSwapchainKHR logicalDevice createInfo Nothing) Vk.withSwapchainKHR logicalDevice createInfo Nothing allocate
(\swapchain -> do
putStrLn "destroying swapchain"
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
)
let depthImageExtent = let depthImageExtent =
(\(V2 w h) -> Vk.Extent3D (fromIntegral w) (fromIntegral h) 1) (\(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 , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
} }
(depthImage, depthAllocation, _) <- snd <$> allocate (depthImage, depthAllocation, _) <- snd <$>
(VMA.createImage allocator depthImageInfo depthImageAllocationInfo) VMA.withImage allocator depthImageInfo depthImageAllocationInfo allocate
(\(depthImage, depthAllocation, _) -> do
putStrLn "destroying image"
VMA.destroyImage allocator depthImage depthAllocation
)
let allocatedImage = AllocatedImage depthImage depthAllocation let allocatedImage = AllocatedImage depthImage depthAllocation
depthImageView = imageviewCreate depthImageView = imageviewCreate
@ -200,12 +188,8 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice allocator =
Vk.FORMAT_D32_SFLOAT Vk.FORMAT_D32_SFLOAT
Vk.IMAGE_ASPECT_DEPTH_BIT Vk.IMAGE_ASPECT_DEPTH_BIT
depthImageview <- snd <$> allocate depthImageview <- snd <$>
(Vk.createImageView logicalDevice depthImageView Nothing) Vk.withImageView logicalDevice depthImageView Nothing allocate
(\depthImageview -> do
putStrLn "destroying image view"
Vk.destroyImageView logicalDevice depthImageview Nothing
)
return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace, depthImageview, allocatedImage) return (swapchain, Vk.SurfaceFormatKHR surfaceFormat colorSpace, depthImageview, allocatedImage)
@ -243,11 +227,7 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do
, layerCount = 1 , layerCount = 1
} }
} }
snd <$> allocate snd <$>
(Vk.createImageView logicalDevice createInfo Nothing) Vk.withImageView logicalDevice createInfo Nothing allocate
(\imageView -> do
putStrLn "destroying image view"
Vk.destroyImageView logicalDevice imageView Nothing
)
) )
handles handles

View file

@ -77,7 +77,6 @@ drawFrame engineData frameNumber = do
V.singleton $ framePresentSemaphore frame V.singleton $ framePresentSemaphore frame
} }
-- liftIO $ putStrLn "submitting to queue"
Vk.queueSubmit Vk.queueSubmit
(engineQueue engineData) (engineQueue engineData)
(V.singleton (Vk.SomeStruct submitInfo)) (V.singleton (Vk.SomeStruct submitInfo))
@ -89,7 +88,6 @@ drawFrame engineData frameNumber = do
, Khr.imageIndices = V.singleton index , Khr.imageIndices = V.singleton index
} }
-- liftIO $ putStrLn "presenting queue"
presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo presentResult <- Khr.queuePresentKHR (engineQueue engineData) presentInfo
unless (presentResult == Vk.SUCCESS) $ unless (presentResult == Vk.SUCCESS) $

View file

@ -39,11 +39,6 @@ createFramebuffer
let createInfo = framebufferCreateInfo let createInfo = framebufferCreateInfo
{ Vk.attachments = V.fromList [ imageView, depthImageView ] { Vk.attachments = V.fromList [ imageView, depthImageView ]
} :: Vk.FramebufferCreateInfo '[] } :: Vk.FramebufferCreateInfo '[]
snd <$> allocate snd <$> Vk.withFramebuffer logicalDevice createInfo Nothing allocate
(Vk.createFramebuffer logicalDevice createInfo Nothing)
(\framebuffer -> do
putStrLn "destroying framebuffer"
Vk.destroyFramebuffer logicalDevice framebuffer Nothing
)
) )
swapchainImageViews swapchainImageViews

View file

@ -49,12 +49,8 @@ loadShader logicalDevice shaderPath stage = do
{ Vk.code = shader { Vk.code = shader
} }
snd <$> allocate snd <$>
(Vk.createShaderModule logicalDevice createInfo Nothing) Vk.withShaderModule logicalDevice createInfo Nothing allocate
(\shaderModule -> do
putStrLn "destroying shader module"
Vk.destroyShaderModule logicalDevice shaderModule Nothing
)
createRenderPass createRenderPass
:: (MonadResource m) :: (MonadResource m)
@ -126,12 +122,8 @@ createRenderPass
, Vk.dependencies = V.fromList [ subpassDependency, subpassDepthDependency ] , Vk.dependencies = V.fromList [ subpassDependency, subpassDepthDependency ]
} :: Vk.RenderPassCreateInfo '[] } :: Vk.RenderPassCreateInfo '[]
snd <$> allocate snd <$>
(Vk.createRenderPass logicalDevice renderPassCreateInfo Nothing) Vk.withRenderPass logicalDevice renderPassCreateInfo Nothing allocate
(\renderPass -> do
putStrLn "destroying render pass"
Vk.destroyRenderPass logicalDevice renderPass Nothing
)
createShaderStageCreateInfo createShaderStageCreateInfo
:: Vk.ShaderStageFlagBits :: Vk.ShaderStageFlagBits
@ -300,25 +292,18 @@ createGraphicsPipelines
, Vk.basePipelineIndex = -1 , Vk.basePipelineIndex = -1
} }
pipeline <- snd <$> allocate pipeline <-
(do (do
(result, pipelines) <- Vk.createGraphicsPipelines (result, pipelines) <- snd <$> Vk.withGraphicsPipelines
logicalDevice logicalDevice
Vk.NULL_HANDLE Vk.NULL_HANDLE
(V.singleton (Vk.SomeStruct pipelineCreateInfo)) (V.singleton (Vk.SomeStruct pipelineCreateInfo))
Nothing Nothing
allocate
unless (result == Vk.SUCCESS) $ unless (result == Vk.SUCCESS) $
error "createGraphicsPipelines: Failed creating pipelines" error "createGraphicsPipelines: Failed creating pipelines"
return 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 let material = Material (V.head pipeline) pipelineLayout
matLibraryTMVar <- asks materialLibrary matLibraryTMVar <- asks materialLibrary
matLibrary <- liftIO $ STM.atomically $ STM.readTMVar matLibraryTMVar matLibrary <- liftIO $ STM.atomically $ STM.readTMVar matLibraryTMVar
@ -333,7 +318,7 @@ createMeshPipelineLayout
createMeshPipelineLayout logicalDevice layouts = do createMeshPipelineLayout logicalDevice layouts = do
let pushConstantRange = Vk.zero let pushConstantRange = Vk.zero
{ Vk.offset = 0 { Vk.offset = 0
, Vk.size = fromIntegral (sizeOf (undefinedMeshPushConstants)) , Vk.size = fromIntegral (sizeOf undefinedMeshPushConstants)
, Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT , Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT
} }
pipelineLayoutCreateInfo = Vk.zero pipelineLayoutCreateInfo = Vk.zero
@ -341,9 +326,5 @@ createMeshPipelineLayout logicalDevice layouts = do
, Vk.setLayouts = layouts , Vk.setLayouts = layouts
} }
snd <$> allocate snd <$>
(Vk.createPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing) Vk.withPipelineLayout logicalDevice pipelineLayoutCreateInfo Nothing allocate
(\pipelineLayout -> do
putStrLn "destroying pipeline layout"
Vk.destroyPipelineLayout logicalDevice pipelineLayout Nothing
)

View file

@ -229,25 +229,13 @@ initDescriptors device = do
] ]
} }
(_, descriptorSetLayout1) <- allocate (_, descriptorSetLayout1) <-
(Vk.createDescriptorSetLayout device setInfo Nothing) Vk.withDescriptorSetLayout device setInfo Nothing allocate
(\descriptorLayout -> do
putStrLn "destroying descriptor layout"
Vk.destroyDescriptorSetLayout device descriptorLayout Nothing
)
(_, descriptorSetLayout2) <- allocate (_, descriptorSetLayout2) <-
(Vk.createDescriptorSetLayout device setInfo2 Nothing) Vk.withDescriptorSetLayout device setInfo2 Nothing allocate
(\descriptorLayout -> do
putStrLn "destroying descriptor layout"
Vk.destroyDescriptorSetLayout device descriptorLayout Nothing
)
(_, descriptorPool) <- allocate (_, descriptorPool) <-
(Vk.createDescriptorPool device poolInfo Nothing) Vk.withDescriptorPool device poolInfo Nothing allocate
(\descriptorPoolInfo -> do
putStrLn "destroying descriptor pool"
Vk.destroyDescriptorPool device descriptorPoolInfo Nothing
)
return (descriptorSetLayout1, descriptorSetLayout2, descriptorPool) return (descriptorSetLayout1, descriptorSetLayout2, descriptorPool)

View file

@ -32,11 +32,6 @@ createInstance window = do
, Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation" , Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation"
} }
(_, inst) <- allocate (_, inst) <- Vk.withInstance createInfo Nothing allocate
(Vk.createInstance createInfo Nothing)
(\inst -> do
putStrLn "destroying instance"
Vk.destroyInstance inst Nothing
)
return inst return inst

View file

@ -80,12 +80,8 @@ createBufferView logicalDevice = do
Vk.BUFFER_USAGE_UNIFORM_TEXEL_BUFFER_BIT Vk.BUFFER_USAGE_UNIFORM_TEXEL_BUFFER_BIT
, Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE
} }
buffer <- snd <$> allocate buffer <- snd <$>
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing) (Vk.withBuffer logicalDevice bufferCreateInfo Nothing allocate)
(\buffer -> do
putStrLn "destroying buffer"
Vk.destroyBuffer logicalDevice buffer Nothing
)
let bufferViewCreateInfo = Vk.zero let bufferViewCreateInfo = Vk.zero
{ Vk.buffer = buffer { Vk.buffer = buffer
@ -94,12 +90,7 @@ createBufferView logicalDevice = do
, Vk.range = Vk.WHOLE_SIZE , Vk.range = Vk.WHOLE_SIZE
} }
allocate Vk.withBufferView logicalDevice bufferViewCreateInfo Nothing allocate
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
(\bufferView -> do
putStrLn "destroying bufferView"
Vk.destroyBufferView logicalDevice bufferView Nothing
)
allocateMemory allocateMemory
:: (MonadResource m) :: (MonadResource m)
@ -114,9 +105,4 @@ allocateMemory logicalDevice buffer = do
, Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String) , Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String)
} }
allocate Vk.withMemory logicalDevice memoryAllocateInfo Nothing allocate
(Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing)
(\memory -> do
putStrLn "Freeing memory"
Vk.freeMemory logicalDevice memory Nothing
)

View file

@ -68,11 +68,7 @@ createAllocatedBuffer allocator allocationSize usage memoryUsage = do
, VMA.preferredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT , VMA.preferredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
} :: VMA.AllocationCreateInfo } :: VMA.AllocationCreateInfo
(_, (buffer, newAllocation, info)) <- allocate (_, (buffer, newAllocation, info)) <-
(VMA.createBuffer allocator bufferCreateInfo vmaAllocationInfo) VMA.withBuffer allocator bufferCreateInfo vmaAllocationInfo allocate
(\(buffer, newAllocation, _) -> do
putStrLn "destroying buffer"
VMA.destroyBuffer allocator buffer newAllocation
)
return $ AllocatedBuffer buffer newAllocation info return $ AllocatedBuffer buffer newAllocation info

View file

@ -62,21 +62,13 @@ uploadMesh vertices allocator = do
allocationCreateInfo = Vk.zero allocationCreateInfo = Vk.zero
{ VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU { VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
} :: VMA.AllocationCreateInfo } :: VMA.AllocationCreateInfo
(_, mesh) <- allocate mesh <- do
(do (buffer, bAllocation, bInfo) <- snd <$>
(buffer, bAllocation, bInfo) <- VMA.createBuffer allocator bufferCreateInfo allocationCreateInfo VMA.withBuffer allocator bufferCreateInfo allocationCreateInfo allocate
return (Mesh vertices (AllocatedBuffer buffer bAllocation bInfo)) return (Mesh vertices (AllocatedBuffer buffer bAllocation bInfo))
)
(\(Mesh _ (AllocatedBuffer buffer bAllocation _)) -> do
putStrLn "destroying mesh"
VMA.destroyBuffer allocator buffer bAllocation
)
(dataReleaseKey, dataPtr) <- allocate (dataReleaseKey, dataPtr) <-
(VMA.mapMemory allocator (bufferAllocation $ meshBuffer mesh)) VMA.withMappedMemory allocator (bufferAllocation $ meshBuffer mesh) allocate
(\_ -> do
VMA.unmapMemory allocator (bufferAllocation $ meshBuffer mesh)
)
liftIO $ mapM_ (\(idx, vertex) -> liftIO $ mapM_ (\(idx, vertex) ->
poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex poke (castPtr (dataPtr `plusPtr` (idx * sizeOf vertex))) vertex