optimize allocations

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)

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

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) $

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

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

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)

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

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

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

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