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

View file

@ -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: