From 104ce0babaa43a7cf03e7f02ee60ca4fcf351703 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 18 Jan 2022 06:25:58 +0100 Subject: [PATCH] get device set up properly --- src/Main.hs | 213 +++++++++++++++++++++++++++--------------- vulkan-tutorial.cabal | 1 + 2 files changed, 137 insertions(+), 77 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 15af792..4a48d6d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} module Main where import Control.Monad @@ -33,14 +34,14 @@ import qualified Vulkan.Utils.Initialization as Vk import qualified Vulkan.Utils.QueueAssignment as Vk import qualified Vulkan.Utils.Requirements as Vk import qualified Vulkan.Zero as Vk -import qualified Vulkan as SDL +import qualified VulkanMemoryAllocator as Vk myApiVersion :: Word32 myApiVersion = Vk.API_VERSION_1_2 main :: IO () main = runResourceT $ do - window <- initEngine + (window, inst, surface) <- initEngine SDL.showWindow window @@ -64,9 +65,9 @@ main = runResourceT $ do evs ) - quitEngine window + quitEngine window inst surface -initEngine :: MonadResource m => m SDL.Window +initEngine :: MonadResource m => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR) initEngine = do -- initialize SDL2 with all subsystems SDL.initializeAll @@ -80,27 +81,56 @@ initEngine = do SDL.vkLoadLibrary Nothing -- create the window - window <- SDL.createWindow "Vulkan window" windowConfig + window <- SDL.createWindow "Haskell ❤️ Vulkan" windowConfig - surface <- initVulkan window + (surface, inst) <- initVulkan window - return window + return (window, inst, surface) -initVulkan :: MonadResource m => SDL.Window -> m SDL.VkSurfaceKHR +initVulkan :: MonadResource m => SDL.Window -> m (Vk.SurfaceKHR, Vk.Instance) initVulkan window = do vulkanInstance <- createInstance window -- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance -- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice - SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) + vulkanSurface <- Vk.SurfaceKHR <$> + SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) + DeviceParams + devName + physicalDevice + logicalDevice + graphicsQueue + graphicsQueueFamilyIndex <- createDevice vulkanInstance vulkanSurface + + let commandPoolCreateInfo = Vk.zero + { Vk.queueFamilyIndex = graphicsQueueFamilyIndex + } :: Vk.CommandPoolCreateInfo + commandPools <- + V.replicateM + 3 + (snd <$> + Vk.withCommandPool logicalDevice commandPoolCreateInfo Nothing allocate + ) + + allocator <- createVMA vulkanInstance physicalDevice logicalDevice + + liftIO $ print ("Using device: " <> devName) + + return (vulkanSurface, vulkanInstance) -quitEngine :: MonadResource m => SDL.Window -> Vk.Instance -> > m () -quitEngine inst surface window = liftIO $ do - -- destroy instance +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 @@ -118,74 +148,103 @@ createInstance window = do } } requirements = - (\n -> Vk.RequireInstanceExtension Nothing n minBound) <$> - ( Vk.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME - : windowExtensions - ) - Vk.createInstanceFromRequirements requirements [] createInfo + [Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ] + Vk.createDebugInstanceFromRequirements requirements [] createInfo -pickPhysicalDevice :: MonadResource m => Vk.Instance -> m Vk.PhysicalDevice -pickPhysicalDevice inst = do - (_, devices) <- Vk.enumeratePhysicalDevices inst - when (V.null devices) (error "Failed to find GPUs with Vulkan support") - mDevice <- V.foldM - (\acc dev -> do - suitability <- isDeviceSuitable dev - if suitability && isNothing acc - then - return (Just dev) - else - return acc - ) - Nothing - devices - return $ fromMaybe - (error "Failed to find suitable GPU") - mDevice +data DeviceParams = DeviceParams + { dpDevicename :: T.Text + , dpPhysicalDevice :: Vk.PhysicalDevice + , dpDevice :: Vk.Device + , dpGraphicsQueue :: Vk.Queue + , dpGraphicsQueueFamilyIndex :: Word32 + } -isDeviceSuitable :: MonadResource m => Vk.PhysicalDevice -> m Bool -isDeviceSuitable device = do - props <- Vk.getPhysicalDeviceProperties device - features <- Vk.getPhysicalDeviceFeatures device - queues <- isJust <$> findQueueFamilies device +createDevice + :: MonadResource m + => Vk.Instance + -> Vk.SurfaceKHR + -> m DeviceParams +createDevice inst surface = do + (pdi, physDevice) <- + fromMaybe (error "Unable to find suitable physival device!") <$> + Vk.pickPhysicalDevice inst (physicalDeviceInfo surface) id - return - ( Vk.deviceType props == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU && - Vk.geometryShader features && - queues - ) + devName <- Vk.physicalDeviceName physDevice + -- + -- get logical device + -- -findQueueFamilies :: MonadIO m => Vk.PhysicalDevice -> m (Maybe Word32) -findQueueFamilies device = do - familyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties device - return $ snd $ V.foldl - (\acc@(curInd, index) prop -> - let flags = Vk.queueFlags prop - in - ( curInd + 1 - , if (flags .&. Vk.QUEUE_GRAPHICS_BIT) == Vk.QueueFlagBits 0 - then index - else Just curInd - ) - ) - (0, Nothing) - familyProperties - + let graphicsQueueFamilyIndex = pdiGraphicsQueueFamilyIndex pdi + deviceCreateInfo = Vk.zero + { Vk.queueCreateInfos = + [ Vk.SomeStruct Vk.zero + { Vk.queueFamilyIndex = graphicsQueueFamilyIndex + , Vk.queuePriorities = [ 1 ] + } + ] + , Vk.enabledExtensionNames = [ Vk.KHR_SWAPCHAIN_EXTENSION_NAME ] + } + (_, device) <- Vk.withDevice physDevice deviceCreateInfo Nothing allocate + graphicsQueue <- + Vk.getDeviceQueue device graphicsQueueFamilyIndex 0 --- createLogicalDevice :: MonadResource m => Vk.PhysicalDevice -> m Vk.Device --- createLogicalDevice device = do --- queueFamilies <- liftIO $ Vk.getPhysicalDeviceQueueFamilyProperties device --- index <- liftIO (fromJust <$> findQueueFamilies device) --- let queueCreateInfo = Vk.zero --- { Vk.queueFamilyIndex = index --- , Vk.queuePriorities = V.singleton 1 --- } --- deviceFeatures = Nothing --- deviceCreateInfo = Vk.zero --- { Vk.queueCreateInfos = V.singleton queueCreateInfo --- , Vk.enabledFeatures = deviceFeatures --- , Vk.enabledExtensionNames = V.empty --- } :: Vk.DeviceCreateInfo '[] --- Vk.createDevice device deviceCreateInfo Nothing --- + return $ DeviceParams + devName + physDevice + device + graphicsQueue + graphicsQueueFamilyIndex + +data PhysicalDeviceInfo = PhysicalDeviceInfo + { pdiTotalMemory :: Word64 + , pdiGraphicsQueueFamilyIndex :: Word32 + } + deriving (Eq, Ord) + +physicalDeviceInfo + :: MonadIO m + => Vk.SurfaceKHR + -> Vk.PhysicalDevice + -> m (Maybe PhysicalDeviceInfo) +physicalDeviceInfo surface phys = runMaybeT $ do + -- We need swapchains + guard =<< deviceHasSwapchains phys + + -- We also need graphics and present queues + pdiGraphicsQueueFamilyIndex <- do + queueFamilyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties phys + 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 + pdiTotalMemory <- do + heaps <- Vk.memoryHeaps <$> Vk.getPhysicalDeviceMemoryProperties phys + return $ sum (( Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize) <$> heaps) + + return $ PhysicalDeviceInfo {..} + +deviceHasSwapchains :: MonadIO m => Vk.PhysicalDevice -> m Bool +deviceHasSwapchains phys = do + (_, extensions) <- Vk.enumerateDeviceExtensionProperties phys Nothing + 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 diff --git a/vulkan-tutorial.cabal b/vulkan-tutorial.cabal index 480c007..e1773e1 100644 --- a/vulkan-tutorial.cabal +++ b/vulkan-tutorial.cabal @@ -31,6 +31,7 @@ executable vulkan-tutorial , sdl2 , vulkan , vulkan-utils + , VulkanMemoryAllocator , linear , monad-loops , stm