giant step forward

This commit is contained in:
nek0 2022-07-10 19:31:44 +02:00
parent 3ca8e62367
commit a95928ee9b

View file

@ -9,30 +9,25 @@ 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 Control.Monad.Trans.Maybe
import Data.Bits
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Word import Data.Word
import qualified SDL import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
import Foreign.C.Types (CInt)
import Foreign.Ptr import Foreign.Ptr
import Linear
import qualified Vulkan as Vk import qualified Vulkan as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Requirement as Vk
import qualified Vulkan.Utils.Initialization as Vk
import qualified Vulkan.Zero as Vk import qualified Vulkan.Zero as Vk
import qualified VulkanMemoryAllocator as Vk import qualified Vulkan.CStruct.Extends as Vk
myApiVersion :: Word32 myApiVersion :: Word32
myApiVersion = Vk.API_VERSION_1_2 myApiVersion = Vk.API_VERSION_1_3
main :: IO () main :: IO ()
main = runResourceT $ do main = runResourceT $ do
(window, inst, surface) <- initEngine (window, inst, surface, swapchain, images) <- initEngine
SDL.showWindow window SDL.showWindow window
@ -56,12 +51,12 @@ main = runResourceT $ do
evs evs
) )
quitEngine window inst surface initEngine
:: MonadResource m
initEngine :: MonadResource m => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR) => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image)
initEngine = do initEngine = do
-- initialize SDL2 with all subsystems -- initialize SDL2 with all subsystems
SDL.initializeAll void $ allocate_ SDL.initializeAll SDL.quit
-- create a window configuration -- create a window configuration
let windowConfig = SDL.defaultWindow let windowConfig = SDL.defaultWindow
@ -72,170 +67,157 @@ initEngine = do
SDL.vkLoadLibrary Nothing SDL.vkLoadLibrary Nothing
-- create the window -- create the window
window <- SDL.createWindow "Haskell ❤️ Vulkan" windowConfig (_, window) <-
allocate
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
(\window -> do
liftIO $ print ("destroying window" :: String)
SDL.destroyWindow window
)
(surface, inst) <- initVulkan window -- create vulkan surface and vulkan instance from window
(surface, inst, swapchain, images) <- initVulkan window
return (window, inst, surface, swapchain, images)
return (window, inst, surface) initVulkan
:: MonadResource m
initVulkan :: MonadResource m => SDL.Window -> m (Vk.SurfaceKHR, Vk.Instance) => SDL.Window
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image)
initVulkan window = do initVulkan window = do
vulkanInstance <- createInstance window vulkanInstance <- createInstance window
-- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
vulkanSurface <- Vk.SurfaceKHR <$> vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
DeviceParams
devName
physicalDevice
logicalDevice
graphicsQueue
graphicsQueueFamilyIndex <- createDevice vulkanInstance vulkanSurface
let commandPoolCreateInfo = Vk.zero (_, vulkanSurface) <- allocate
{ Vk.queueFamilyIndex = graphicsQueueFamilyIndex (Vk.SurfaceKHR <$>
} :: Vk.CommandPoolCreateInfo SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
commandPools <- )
V.replicateM (\vulkanSurface -> do
3 print ("destroying Surface" :: String)
(snd <$> Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
Vk.withCommandPool logicalDevice commandPoolCreateInfo Nothing allocate )
)
allocator <- createVMA vulkanInstance physicalDevice logicalDevice dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice
images <- getImageHandles swapchain vulkanLogicalDevice
liftIO $ print ("Using device: " <> devName) return (vulkanSurface, vulkanInstance, swapchain, images)
return (vulkanSurface, vulkanInstance)
quitEngine
:: MonadResource m
=> SDL.Window
-> Vk.Instance
-> Vk.SurfaceKHR
-> m ()
quitEngine window inst surface = liftIO $ do
Vk.destroySurfaceKHR inst surface Nothing
Vk.destroyInstance inst Nothing
-- destroy window
SDL.destroyWindow window
-- quit SDL
SDL.quit
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
createInstance window = do createInstance window = do
windowExtensions <- liftIO $ windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
liftIO $ do
print ("activating followinfg rxtensions:" :: String)
print windowExtensions
let createInfo = Vk.zero let createInfo = Vk.zero
{ Vk.applicationInfo = Just Vk.zero { Vk.applicationInfo = Just Vk.zero
{ Vk.applicationName = Nothing { Vk.applicationName = Nothing
, Vk.apiVersion = myApiVersion , 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"
} }
requirements = -- requirements =
[Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ] -- [Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ]
Vk.createDebugInstanceFromRequirements requirements [] createInfo
data DeviceParams = DeviceParams (_, inst) <- allocate
{ dpDevicename :: T.Text (Vk.createInstance createInfo Nothing)
, dpPhysicalDevice :: Vk.PhysicalDevice (`Vk.destroyInstance` Nothing)
, dpDevice :: Vk.Device
, dpGraphicsQueue :: Vk.Queue
, dpGraphicsQueueFamilyIndex :: Word32
}
createDevice return inst
:: MonadResource m
pickPhysicalDevice
:: (MonadResource m)
=> Vk.Instance => Vk.Instance
-> Vk.SurfaceKHR -> m Vk.PhysicalDevice
-> m DeviceParams pickPhysicalDevice vkInstance = do
createDevice inst surface = do physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
(pdi, physDevice) <-
fromMaybe (error "Unable to find suitable physival device!") <$>
Vk.pickPhysicalDevice inst (physicalDeviceInfo surface) id
devName <- Vk.physicalDeviceName physDevice devicesWithProps <- V.mapM
(\device -> do
devProps <- Vk.getPhysicalDeviceProperties device
return (device, devProps)
)
physDevices
-- let discretePhysDevices = V.filter
-- get logical device (\(_, 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
let graphicsQueueFamilyIndex = pdiGraphicsQueueFamilyIndex pdi return maxMemdiscretePhysDevice
deviceCreateInfo = Vk.zero
{ Vk.queueCreateInfos = createLogicalDevice
[ Vk.SomeStruct Vk.zero :: (MonadResource m)
{ Vk.queueFamilyIndex = graphicsQueueFamilyIndex => Vk.PhysicalDevice
, Vk.queuePriorities = [ 1 ] -> m Vk.Device
} createLogicalDevice physDevice = do
] let priorities = V.singleton 1
, Vk.enabledExtensionNames = [ Vk.KHR_SWAPCHAIN_EXTENSION_NAME ] 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
} }
(_, device) <- Vk.withDevice physDevice deviceCreateInfo Nothing allocate
graphicsQueue <-
Vk.getDeviceQueue device graphicsQueueFamilyIndex 0
return $ DeviceParams (_, logDevice) <- allocate
devName (Vk.createDevice physDevice deviceCreateInfo Nothing)
physDevice (\logDevice -> do
device print ("destroying logical device" :: String)
graphicsQueue Vk.destroyDevice logDevice Nothing
graphicsQueueFamilyIndex )
data PhysicalDeviceInfo = PhysicalDeviceInfo return logDevice
{ pdiTotalMemory :: Word64
, pdiGraphicsQueueFamilyIndex :: Word32
}
deriving (Eq, Ord)
physicalDeviceInfo createSwapchain
:: MonadIO m :: (MonadResource m)
=> Vk.SurfaceKHR => Vk.SurfaceKHR
-> Vk.PhysicalDevice -> V2 CInt
-> m (Maybe PhysicalDeviceInfo) -> Vk.Device
physicalDeviceInfo surface phys = runMaybeT $ do -> m Vk.SwapchainKHR
-- We need swapchains createSwapchain surface windowDimension logicalDevice = do
guard =<< deviceHasSwapchains phys 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
}
-- We also need graphics and present queues snd <$> allocate
pdiGraphicsQueueFamilyIndex <- do (Vk.createSwapchainKHR logicalDevice createInfo Nothing)
queueFamilyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties phys (\swapchain -> Vk.destroySwapchainKHR logicalDevice swapchain Nothing)
let isGraphicsQueue q =
((Vk.QUEUE_GRAPHICS_BIT .&. Vk.queueFlags q) > Vk.QueueFlagBits 0) &&
(Vk.queueCount q > 0)
graphicsQueueIndices = fromIntegral . fst <$> V.filter
(isGraphicsQueue . snd)
(V.indexed queueFamilyProperties)
isPresentQueue i = Vk.getPhysicalDeviceSurfaceSupportKHR phys i surface
presentQueueIndices <- V.filterM isPresentQueue graphicsQueueIndices
MaybeT (return $ presentQueueIndices V.!? 0)
-- Score based on total memory getImageHandles
pdiTotalMemory <- do :: (MonadResource m)
heaps <- Vk.memoryHeaps <$> Vk.getPhysicalDeviceMemoryProperties phys => Vk.SwapchainKHR
return $ sum (( Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize) <$> heaps) -> Vk.Device
-> m (V.Vector Vk.Image)
return $ PhysicalDeviceInfo {..} getImageHandles swapchain logicalDevice = do
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
deviceHasSwapchains :: MonadIO m => Vk.PhysicalDevice -> m Bool when (result /= Vk.SUCCESS) $
deviceHasSwapchains phys = do error "getImageHandles: Failed acquiring images from swapchain"
(_, extensions) <- Vk.enumerateDeviceExtensionProperties phys Nothing return handles
return $
V.any ((Vk.KHR_SWAPCHAIN_EXTENSION_NAME ==) . Vk.extensionName) extensions
createVMA :: MonadResource m => Vk.Instance -> Vk.PhysicalDevice -> Vk.Device -> m Vk.Allocator
createVMA inst physicalDevice logicalDevice = snd <$>
Vk.withAllocator
Vk.zero
{ Vk.flags = Vk.zero
, Vk.physicalDevice = Vk.physicalDeviceHandle physicalDevice
, Vk.device = Vk.deviceHandle logicalDevice
, Vk.instance' = Vk.instanceHandle inst
, Vk.vulkanApiVersion = myApiVersion
}
allocate