add basic memory management and split into modules
This commit is contained in:
parent
b62515426c
commit
8b4dc69e5c
107
src/Devices.hs
Normal file
107
src/Devices.hs
Normal file
|
@ -0,0 +1,107 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
module Devices where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
import Foreign.C.Types (CInt)
|
||||||
|
import Linear
|
||||||
|
import qualified Vulkan as Vk
|
||||||
|
import qualified Vulkan.Zero as Vk
|
||||||
|
import qualified Vulkan.CStruct.Extends as Vk
|
||||||
|
|
||||||
|
pickPhysicalDevice
|
||||||
|
:: (MonadResource m)
|
||||||
|
=> Vk.Instance
|
||||||
|
-> m Vk.PhysicalDevice
|
||||||
|
pickPhysicalDevice vkInstance = do
|
||||||
|
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
|
||||||
|
|
||||||
|
devicesWithProps <- V.mapM
|
||||||
|
(\device -> do
|
||||||
|
devProps <- Vk.getPhysicalDeviceProperties device
|
||||||
|
return (device, devProps)
|
||||||
|
)
|
||||||
|
physDevices
|
||||||
|
|
||||||
|
let discretePhysDevices = V.filter
|
||||||
|
(\(_, devProp) -> Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU)
|
||||||
|
devicesWithProps
|
||||||
|
maxMemdiscretePhysDevice = fst $ V.foldl
|
||||||
|
(\acc@(_, devProp1) ndev@(_, devProp2) ->
|
||||||
|
let dimension = Vk.maxImageDimension2D . Vk.limits
|
||||||
|
in
|
||||||
|
if dimension devProp1 < dimension devProp2
|
||||||
|
then ndev
|
||||||
|
else acc
|
||||||
|
)
|
||||||
|
(V.head discretePhysDevices)
|
||||||
|
discretePhysDevices
|
||||||
|
|
||||||
|
return maxMemdiscretePhysDevice
|
||||||
|
|
||||||
|
createLogicalDevice
|
||||||
|
:: (MonadResource m)
|
||||||
|
=> Vk.PhysicalDevice
|
||||||
|
-> m Vk.Device
|
||||||
|
createLogicalDevice physDevice = do
|
||||||
|
let priorities = V.singleton 1
|
||||||
|
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
|
||||||
|
queueCreateInfo = Vk.zero
|
||||||
|
{ Vk.queueFamilyIndex = 0
|
||||||
|
, Vk.queuePriorities = priorities
|
||||||
|
}
|
||||||
|
deviceCreateInfo = Vk.zero
|
||||||
|
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
|
||||||
|
, Vk.enabledExtensionNames = extensionNames
|
||||||
|
}
|
||||||
|
|
||||||
|
(_, logDevice) <- allocate
|
||||||
|
(Vk.createDevice physDevice deviceCreateInfo Nothing)
|
||||||
|
(\logDevice -> do
|
||||||
|
print ("destroying logical device" :: String)
|
||||||
|
Vk.destroyDevice logDevice Nothing
|
||||||
|
)
|
||||||
|
|
||||||
|
return logDevice
|
||||||
|
|
||||||
|
createSwapchain
|
||||||
|
:: (MonadResource m)
|
||||||
|
=> Vk.SurfaceKHR
|
||||||
|
-> V2 CInt
|
||||||
|
-> Vk.Device
|
||||||
|
-> m Vk.SwapchainKHR
|
||||||
|
createSwapchain surface windowDimension logicalDevice = do
|
||||||
|
let createInfo = Vk.zero
|
||||||
|
{ Vk.surface = surface
|
||||||
|
, Vk.minImageCount = 4
|
||||||
|
, Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB
|
||||||
|
, Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR
|
||||||
|
, Vk.imageExtent =
|
||||||
|
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
|
||||||
|
, Vk.imageArrayLayers = 1
|
||||||
|
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
|
||||||
|
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
|
||||||
|
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
|
||||||
|
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR
|
||||||
|
}
|
||||||
|
|
||||||
|
snd <$> allocate
|
||||||
|
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
|
||||||
|
(\swapchain -> do
|
||||||
|
print ("destroying Swapchain" :: String)
|
||||||
|
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
|
||||||
|
)
|
||||||
|
|
||||||
|
getImageHandles
|
||||||
|
:: (MonadResource m)
|
||||||
|
=> Vk.SwapchainKHR
|
||||||
|
-> Vk.Device
|
||||||
|
-> m (V.Vector Vk.Image)
|
||||||
|
getImageHandles swapchain logicalDevice = do
|
||||||
|
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
|
||||||
|
when (result /= Vk.SUCCESS) $
|
||||||
|
error "getImageHandles: Failed acquiring images from swapchain"
|
||||||
|
return handles
|
86
src/Init.hs
Normal file
86
src/Init.hs
Normal file
|
@ -0,0 +1,86 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
module Init where
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Loops
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
import Data.Bits
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
import Data.Word
|
||||||
|
import qualified SDL hiding (V2)
|
||||||
|
import qualified SDL.Video.Vulkan as SDL
|
||||||
|
import qualified Control.Concurrent.STM as STM
|
||||||
|
import Foreign.C.Types (CInt)
|
||||||
|
import Foreign.Ptr
|
||||||
|
import Linear
|
||||||
|
import qualified Vulkan as Vk
|
||||||
|
import qualified Vulkan.Zero as Vk
|
||||||
|
import qualified Vulkan.CStruct.Extends as Vk
|
||||||
|
|
||||||
|
-- internal imports
|
||||||
|
|
||||||
|
import Instance
|
||||||
|
import Devices
|
||||||
|
|
||||||
|
initEngine
|
||||||
|
:: MonadResource m
|
||||||
|
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image)
|
||||||
|
initEngine = do
|
||||||
|
-- initialize SDL2 with all subsystems
|
||||||
|
void $ allocate_
|
||||||
|
SDL.initializeAll
|
||||||
|
(do
|
||||||
|
print ("This is the end!" :: String)
|
||||||
|
SDL.quit
|
||||||
|
)
|
||||||
|
|
||||||
|
-- create a window configuration
|
||||||
|
let windowConfig = SDL.defaultWindow
|
||||||
|
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
|
||||||
|
}
|
||||||
|
|
||||||
|
-- load vulkan library
|
||||||
|
SDL.vkLoadLibrary Nothing
|
||||||
|
|
||||||
|
-- create the window
|
||||||
|
(_, window) <-
|
||||||
|
allocate
|
||||||
|
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
|
||||||
|
(\window -> do
|
||||||
|
liftIO $ print ("destroying window" :: String)
|
||||||
|
SDL.destroyWindow window
|
||||||
|
)
|
||||||
|
|
||||||
|
-- create vulkan surface and vulkan instance from window
|
||||||
|
(surface, inst, swapchain, images) <- initVulkan window
|
||||||
|
return (window, inst, surface, swapchain, images)
|
||||||
|
|
||||||
|
initVulkan
|
||||||
|
:: MonadResource m
|
||||||
|
=> SDL.Window
|
||||||
|
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image)
|
||||||
|
initVulkan window = do
|
||||||
|
|
||||||
|
vulkanInstance <- createInstance window
|
||||||
|
|
||||||
|
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
|
||||||
|
vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
|
||||||
|
|
||||||
|
(_, vulkanSurface) <- allocate
|
||||||
|
(Vk.SurfaceKHR <$>
|
||||||
|
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
|
||||||
|
)
|
||||||
|
(\vulkanSurface -> do
|
||||||
|
print ("destroying Surface" :: String)
|
||||||
|
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
|
||||||
|
)
|
||||||
|
|
||||||
|
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
|
||||||
|
swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice
|
||||||
|
images <- getImageHandles swapchain vulkanLogicalDevice
|
||||||
|
|
||||||
|
return (vulkanSurface, vulkanInstance, swapchain, images)
|
40
src/Instance.hs
Normal file
40
src/Instance.hs
Normal file
|
@ -0,0 +1,40 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
module Instance where
|
||||||
|
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
import qualified SDL hiding (V2)
|
||||||
|
import qualified SDL.Video.Vulkan as SDL
|
||||||
|
import qualified Vulkan as Vk
|
||||||
|
import qualified Vulkan.Zero as Vk
|
||||||
|
|
||||||
|
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
|
||||||
|
createInstance window = do
|
||||||
|
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
|
||||||
|
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
|
||||||
|
liftIO $ do
|
||||||
|
print ("activating followinfg extensions:" :: String)
|
||||||
|
print windowExtensions
|
||||||
|
let createInfo = Vk.zero
|
||||||
|
{ Vk.applicationInfo = Just Vk.zero
|
||||||
|
{ Vk.applicationName = Nothing
|
||||||
|
, Vk.apiVersion = Vk.API_VERSION_1_3
|
||||||
|
}
|
||||||
|
-- enable debug util extension for debugging purposes
|
||||||
|
, Vk.enabledExtensionNames = V.fromList windowExtensions
|
||||||
|
-- enable validation layer for debugging purposes
|
||||||
|
, Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation"
|
||||||
|
}
|
||||||
|
|
||||||
|
(_, inst) <- allocate
|
||||||
|
(Vk.createInstance createInfo Nothing)
|
||||||
|
(\inst -> do
|
||||||
|
print ("destroying instance" :: String)
|
||||||
|
Vk.destroyInstance inst Nothing
|
||||||
|
)
|
||||||
|
|
||||||
|
return inst
|
223
src/Main.hs
223
src/Main.hs
|
@ -1,14 +1,13 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE OverloadedLists #-}
|
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Loops
|
import Control.Monad.Loops
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
|
import Data.Bits
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
@ -22,8 +21,11 @@ import qualified Vulkan as Vk
|
||||||
import qualified Vulkan.Zero as Vk
|
import qualified Vulkan.Zero as Vk
|
||||||
import qualified Vulkan.CStruct.Extends as Vk
|
import qualified Vulkan.CStruct.Extends as Vk
|
||||||
|
|
||||||
myApiVersion :: Word32
|
-- internal imports
|
||||||
myApiVersion = Vk.API_VERSION_1_3
|
|
||||||
|
import Init
|
||||||
|
import Devices
|
||||||
|
import Instance
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = runResourceT $ do
|
main = runResourceT $ do
|
||||||
|
@ -51,182 +53,55 @@ main = runResourceT $ do
|
||||||
evs
|
evs
|
||||||
)
|
)
|
||||||
|
|
||||||
initEngine
|
createBufferView
|
||||||
:: MonadResource m
|
|
||||||
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image)
|
|
||||||
initEngine = do
|
|
||||||
-- initialize SDL2 with all subsystems
|
|
||||||
void $ allocate_
|
|
||||||
SDL.initializeAll
|
|
||||||
(do
|
|
||||||
print ("This is the end!" :: String)
|
|
||||||
SDL.quit
|
|
||||||
)
|
|
||||||
|
|
||||||
-- create a window configuration
|
|
||||||
let windowConfig = SDL.defaultWindow
|
|
||||||
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
|
|
||||||
}
|
|
||||||
|
|
||||||
-- load vulkan library
|
|
||||||
SDL.vkLoadLibrary Nothing
|
|
||||||
|
|
||||||
-- create the window
|
|
||||||
(_, window) <-
|
|
||||||
allocate
|
|
||||||
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
|
|
||||||
(\window -> do
|
|
||||||
liftIO $ print ("destroying window" :: String)
|
|
||||||
SDL.destroyWindow window
|
|
||||||
)
|
|
||||||
|
|
||||||
-- create vulkan surface and vulkan instance from window
|
|
||||||
(surface, inst, swapchain, images) <- initVulkan window
|
|
||||||
return (window, inst, surface, swapchain, images)
|
|
||||||
|
|
||||||
initVulkan
|
|
||||||
:: MonadResource m
|
|
||||||
=> SDL.Window
|
|
||||||
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image)
|
|
||||||
initVulkan window = do
|
|
||||||
|
|
||||||
vulkanInstance <- createInstance window
|
|
||||||
|
|
||||||
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
|
|
||||||
vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
|
|
||||||
|
|
||||||
(_, vulkanSurface) <- allocate
|
|
||||||
(Vk.SurfaceKHR <$>
|
|
||||||
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
|
|
||||||
)
|
|
||||||
(\vulkanSurface -> do
|
|
||||||
print ("destroying Surface" :: String)
|
|
||||||
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
|
|
||||||
)
|
|
||||||
|
|
||||||
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
|
|
||||||
swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice
|
|
||||||
images <- getImageHandles swapchain vulkanLogicalDevice
|
|
||||||
|
|
||||||
return (vulkanSurface, vulkanInstance, swapchain, images)
|
|
||||||
|
|
||||||
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
|
|
||||||
createInstance window = do
|
|
||||||
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
|
|
||||||
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
|
|
||||||
liftIO $ do
|
|
||||||
print ("activating followinfg extensions:" :: String)
|
|
||||||
print windowExtensions
|
|
||||||
let createInfo = Vk.zero
|
|
||||||
{ Vk.applicationInfo = Just Vk.zero
|
|
||||||
{ Vk.applicationName = Nothing
|
|
||||||
, Vk.apiVersion = myApiVersion
|
|
||||||
}
|
|
||||||
-- enable debug util extension for debugging purposes
|
|
||||||
, Vk.enabledExtensionNames = V.fromList windowExtensions
|
|
||||||
-- enable validation layer for debugging purposes
|
|
||||||
, Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation"
|
|
||||||
}
|
|
||||||
|
|
||||||
(_, inst) <- allocate
|
|
||||||
(Vk.createInstance createInfo Nothing)
|
|
||||||
(\inst -> do
|
|
||||||
print ("destroying instance" :: String)
|
|
||||||
Vk.destroyInstance inst Nothing
|
|
||||||
)
|
|
||||||
|
|
||||||
return inst
|
|
||||||
|
|
||||||
pickPhysicalDevice
|
|
||||||
:: (MonadResource m)
|
:: (MonadResource m)
|
||||||
=> Vk.Instance
|
=> Vk.Device
|
||||||
-> m Vk.PhysicalDevice
|
-> m (ReleaseKey, Vk.BufferView)
|
||||||
pickPhysicalDevice vkInstance = do
|
createBufferView logicalDevice = do
|
||||||
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
|
let bufferCreateInfo = Vk.zero
|
||||||
|
{ Vk.size = 1024
|
||||||
devicesWithProps <- V.mapM
|
, Vk.usage =
|
||||||
(\device -> do
|
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT .|.
|
||||||
devProps <- Vk.getPhysicalDeviceProperties device
|
Vk.BUFFER_USAGE_UNIFORM_TEXEL_BUFFER_BIT
|
||||||
return (device, devProps)
|
, Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE
|
||||||
)
|
|
||||||
physDevices
|
|
||||||
|
|
||||||
let discretePhysDevices = V.filter
|
|
||||||
(\(_, devProp) -> Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU)
|
|
||||||
devicesWithProps
|
|
||||||
maxMemdiscretePhysDevice = fst $ V.foldl
|
|
||||||
(\acc@(_, devProp1) ndev@(_, devProp2) ->
|
|
||||||
let dimension = Vk.maxImageDimension2D . Vk.limits
|
|
||||||
in
|
|
||||||
if dimension devProp1 < dimension devProp2
|
|
||||||
then ndev
|
|
||||||
else acc
|
|
||||||
)
|
|
||||||
(V.head discretePhysDevices)
|
|
||||||
discretePhysDevices
|
|
||||||
|
|
||||||
return maxMemdiscretePhysDevice
|
|
||||||
|
|
||||||
createLogicalDevice
|
|
||||||
:: (MonadResource m)
|
|
||||||
=> Vk.PhysicalDevice
|
|
||||||
-> m Vk.Device
|
|
||||||
createLogicalDevice physDevice = do
|
|
||||||
let priorities = V.singleton 1
|
|
||||||
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
|
|
||||||
queueCreateInfo = Vk.zero
|
|
||||||
{ Vk.queueFamilyIndex = 0
|
|
||||||
, Vk.queuePriorities = priorities
|
|
||||||
}
|
}
|
||||||
deviceCreateInfo = Vk.zero
|
buffer <- snd <$> allocate
|
||||||
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
|
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing)
|
||||||
, Vk.enabledExtensionNames = extensionNames
|
(\buffer -> do
|
||||||
}
|
print ("destroying buffer" :: String)
|
||||||
|
Vk.destroyBuffer logicalDevice buffer Nothing
|
||||||
(_, logDevice) <- allocate
|
|
||||||
(Vk.createDevice physDevice deviceCreateInfo Nothing)
|
|
||||||
(\logDevice -> do
|
|
||||||
print ("destroying logical device" :: String)
|
|
||||||
Vk.destroyDevice logDevice Nothing
|
|
||||||
)
|
)
|
||||||
|
|
||||||
return logDevice
|
let bufferViewCreateInfo = Vk.zero
|
||||||
|
{ Vk.buffer = buffer
|
||||||
createSwapchain
|
, Vk.format = Vk.FORMAT_R32G32B32_SFLOAT
|
||||||
:: (MonadResource m)
|
, Vk.offset = 0
|
||||||
=> Vk.SurfaceKHR
|
, Vk.range = Vk.WHOLE_SIZE
|
||||||
-> V2 CInt
|
|
||||||
-> Vk.Device
|
|
||||||
-> m Vk.SwapchainKHR
|
|
||||||
createSwapchain surface windowDimension logicalDevice = do
|
|
||||||
let createInfo = Vk.zero
|
|
||||||
{ Vk.surface = surface
|
|
||||||
, Vk.minImageCount = 4
|
|
||||||
, Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB
|
|
||||||
, Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR
|
|
||||||
, Vk.imageExtent =
|
|
||||||
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
|
|
||||||
, Vk.imageArrayLayers = 1
|
|
||||||
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
|
|
||||||
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
|
|
||||||
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
|
|
||||||
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR
|
|
||||||
}
|
}
|
||||||
|
|
||||||
snd <$> allocate
|
allocate
|
||||||
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
|
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
|
||||||
(\swapchain -> do
|
(\bufferView -> do
|
||||||
print ("destroying Swapchain" :: String)
|
print ("destroying bufferView" :: String)
|
||||||
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
|
Vk.destroyBufferView logicalDevice bufferView Nothing
|
||||||
)
|
)
|
||||||
|
|
||||||
getImageHandles
|
allocateMemory
|
||||||
:: (MonadResource m)
|
:: (MonadResource m)
|
||||||
=> Vk.SwapchainKHR
|
=> Vk.Device
|
||||||
-> Vk.Device
|
-> Vk.Buffer
|
||||||
-> m (V.Vector Vk.Image)
|
-> m (ReleaseKey, Vk.DeviceMemory)
|
||||||
getImageHandles swapchain logicalDevice = do
|
allocateMemory logicalDevice buffer = do
|
||||||
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
|
memoryRequirements <- Vk.getBufferMemoryRequirements logicalDevice buffer
|
||||||
when (result /= Vk.SUCCESS) $
|
|
||||||
error "getImageHandles: Failed acquiring images from swapchain"
|
let memoryAllocateInfo = Vk.zero
|
||||||
return handles
|
{ Vk.allocationSize = (Vk.size :: Vk.MemoryRequirements -> Word64) memoryRequirements
|
||||||
|
, Vk.memoryTypeIndex = error ("createBuffer: TODO: populate memoryTypeIndex!" :: String)
|
||||||
|
}
|
||||||
|
|
||||||
|
allocate
|
||||||
|
(Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing)
|
||||||
|
(\memory -> do
|
||||||
|
print ("Freeing memory" :: String)
|
||||||
|
Vk.freeMemory logicalDevice memory Nothing
|
||||||
|
)
|
||||||
|
|
|
@ -23,7 +23,9 @@ executable vulkan-tutorial
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
|
|
||||||
-- Modules included in this executable, other than Main.
|
-- Modules included in this executable, other than Main.
|
||||||
-- other-modules:
|
other-modules: Init
|
||||||
|
Instance
|
||||||
|
Devices
|
||||||
|
|
||||||
-- LANGUAGE extensions used by modules in this package.
|
-- LANGUAGE extensions used by modules in this package.
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
|
Loading…
Reference in a new issue