From 8b4dc69e5c605e0034eacff94c785c74947d1f9d Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 11 Jul 2022 01:58:58 +0200 Subject: [PATCH] add basic memory management and split into modules --- src/Devices.hs | 107 ++++++++++++++++++++ src/Init.hs | 86 ++++++++++++++++ src/Instance.hs | 40 ++++++++ src/Main.hs | 223 ++++++++++-------------------------------- vulkan-tutorial.cabal | 4 +- 5 files changed, 285 insertions(+), 175 deletions(-) create mode 100644 src/Devices.hs create mode 100644 src/Init.hs create mode 100644 src/Instance.hs diff --git a/src/Devices.hs b/src/Devices.hs new file mode 100644 index 0000000..faa72b7 --- /dev/null +++ b/src/Devices.hs @@ -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 diff --git a/src/Init.hs b/src/Init.hs new file mode 100644 index 0000000..4849ec9 --- /dev/null +++ b/src/Init.hs @@ -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) diff --git a/src/Instance.hs b/src/Instance.hs new file mode 100644 index 0000000..5c76a7a --- /dev/null +++ b/src/Instance.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 3f44c70..2bd3ec4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 + ) diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal index 29a3400..df8df1e 100644 --- a/vulkan-tutorial.cabal +++ b/vulkan-tutorial.cabal @@ -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: