add basic memory management and split into modules
This commit is contained in:
parent
b62515426c
commit
8b4dc69e5c
5 changed files with 285 additions and 175 deletions
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 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
|
||||
)
|
||||
|
|
|
@ -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:
|
||||
|
|
Loading…
Add table
Reference in a new issue