add basic memory management and split into modules

This commit is contained in:
nek0 2022-07-11 01:58:58 +02:00
parent b62515426c
commit 8b4dc69e5c
5 changed files with 285 additions and 175 deletions

107
src/Devices.hs Normal file
View 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
View 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
View 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

View file

@ -1,14 +1,13 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
module Main 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
@ -22,8 +21,11 @@ import qualified Vulkan as Vk
import qualified Vulkan.Zero as Vk
import qualified Vulkan.CStruct.Extends as Vk
myApiVersion :: Word32
myApiVersion = Vk.API_VERSION_1_3
-- internal imports
import Init
import Devices
import Instance
main :: IO ()
main = runResourceT $ do
@ -51,182 +53,55 @@ main = runResourceT $ do
evs
)
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)
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
createBufferView
:: (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
=> Vk.Device
-> m (ReleaseKey, Vk.BufferView)
createBufferView logicalDevice = do
let bufferCreateInfo = Vk.zero
{ Vk.size = 1024
, Vk.usage =
Vk.BUFFER_USAGE_UNIFORM_BUFFER_BIT .|.
Vk.BUFFER_USAGE_UNIFORM_TEXEL_BUFFER_BIT
, Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE
}
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
buffer <- snd <$> allocate
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing)
(\buffer -> do
print ("destroying buffer" :: String)
Vk.destroyBuffer logicalDevice buffer 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
let bufferViewCreateInfo = Vk.zero
{ Vk.buffer = buffer
, Vk.format = Vk.FORMAT_R32G32B32_SFLOAT
, Vk.offset = 0
, Vk.range = Vk.WHOLE_SIZE
}
snd <$> allocate
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
(\swapchain -> do
print ("destroying Swapchain" :: String)
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
allocate
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
(\bufferView -> do
print ("destroying bufferView" :: String)
Vk.destroyBufferView logicalDevice bufferView Nothing
)
getImageHandles
allocateMemory
:: (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
=> Vk.Device
-> Vk.Buffer
-> m (ReleaseKey, Vk.DeviceMemory)
allocateMemory logicalDevice buffer = do
memoryRequirements <- Vk.getBufferMemoryRequirements logicalDevice buffer
let memoryAllocateInfo = Vk.zero
{ 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
)

View file

@ -23,7 +23,9 @@ executable vulkan-tutorial
main-is: Main.hs
-- Modules included in this executable, other than Main.
-- other-modules:
other-modules: Init
Instance
Devices
-- LANGUAGE extensions used by modules in this package.
-- other-extensions: