vulkan-tutorial/src/Memory.hs
2023-01-16 01:10:23 +01:00

75 lines
2.2 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
module Memory where
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Foreign.Ptr
import qualified VulkanMemoryAllocator as VMA
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Dynamic as Vk
import qualified Vulkan.Zero as Vk
-- internal imports
import Types
initAllocator
:: (MonadResource m, MonadFail m)
=> Vk.PhysicalDevice
-> Vk.Device
-> Vk.Instance
-> m VMA.Allocator
initAllocator physicalDevice device instance' = do
let instanceProcAddr = castFunPtr $
Vk.pVkGetInstanceProcAddr ((Vk.instanceCmds :: Vk.Instance -> Vk.InstanceCmds) instance')
deviceProcAddr = castFunPtr $
Vk.pVkGetDeviceProcAddr ((Vk.deviceCmds :: Vk.Device -> Vk.DeviceCmds) device)
let allocatorInfo = Vk.zero
{ VMA.physicalDevice = Vk.physicalDeviceHandle physicalDevice
, VMA.device = Vk.deviceHandle device
, VMA.instance' = Vk.instanceHandle instance'
, VMA.vulkanFunctions = Just (Vk.zero
{ VMA.vkGetInstanceProcAddr = instanceProcAddr
, VMA.vkGetDeviceProcAddr = deviceProcAddr
} :: VMA.VulkanFunctions)
} :: VMA.AllocatorCreateInfo
(_, allocator) <- allocate
(VMA.createAllocator allocatorInfo)
(\allocator -> do
putStrLn "destroying allocator"
VMA.destroyAllocator allocator
)
return allocator
createAllocatedBuffer
:: (MonadResource m, MonadIO m)
=> Vk.Device
-> VMA.Allocator
-> Int
-> Vk.BufferUsageFlags
-> VMA.MemoryUsage
-> m AllocatedBuffer
createAllocatedBuffer device allocator allocationSize usage memoryUsage = do
let bufferInfo = Vk.zero
{ Vk.size = fromIntegral allocationSize
, Vk.usage = usage
}
vmaAllocationInfo = Vk.zero
{ VMA.usage = memoryUsage
} :: VMA.AllocationCreateInfo
(_, (buffer, newAllocation, _)) <- allocate
(VMA.createBuffer allocator bufferInfo vmaAllocationInfo)
(\(buffer, newAllocation, _) -> do
putStrLn "destroying buffer"
VMA.destroyBuffer allocator buffer newAllocation
)
return $ AllocatedBuffer buffer newAllocation