vulkan-tutorial/src/Memory.hs

{-# 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)
  => VMA.Allocator
  -> Int
  -> Vk.BufferUsageFlags
  -> VMA.MemoryUsage
  -> m AllocatedBuffer
createAllocatedBuffer 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