get device set up properly

This commit is contained in:
nek0 2022-01-18 06:25:58 +01:00
parent c2fc5e8a58
commit 104ce0baba
2 changed files with 137 additions and 77 deletions

View file

@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
module Main where module Main where
import Control.Monad 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.QueueAssignment as Vk
import qualified Vulkan.Utils.Requirements as Vk import qualified Vulkan.Utils.Requirements as Vk
import qualified Vulkan.Zero as Vk import qualified Vulkan.Zero as Vk
import qualified Vulkan as SDL import qualified VulkanMemoryAllocator as Vk
myApiVersion :: Word32 myApiVersion :: Word32
myApiVersion = Vk.API_VERSION_1_2 myApiVersion = Vk.API_VERSION_1_2
main :: IO () main :: IO ()
main = runResourceT $ do main = runResourceT $ do
window <- initEngine (window, inst, surface) <- initEngine
SDL.showWindow window SDL.showWindow window
@ -64,9 +65,9 @@ main = runResourceT $ do
evs 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 initEngine = do
-- initialize SDL2 with all subsystems -- initialize SDL2 with all subsystems
SDL.initializeAll SDL.initializeAll
@ -80,27 +81,56 @@ initEngine = do
SDL.vkLoadLibrary Nothing SDL.vkLoadLibrary Nothing
-- create the window -- 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 initVulkan window = do
vulkanInstance <- createInstance window vulkanInstance <- createInstance window
-- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance -- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice -- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
vulkanSurface <- Vk.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance)) 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
quitEngine inst surface window = liftIO $ do :: MonadResource m
-- destroy instance => SDL.Window
-> Vk.Instance
-> Vk.SurfaceKHR
-> m ()
quitEngine window inst surface = liftIO $ do
Vk.destroySurfaceKHR inst surface Nothing Vk.destroySurfaceKHR inst surface Nothing
Vk.destroyInstance inst Nothing
-- destroy window -- destroy window
SDL.destroyWindow window SDL.destroyWindow window
@ -118,74 +148,103 @@ createInstance window = do
} }
} }
requirements = requirements =
(\n -> Vk.RequireInstanceExtension Nothing n minBound) <$> [Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ]
( Vk.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME Vk.createDebugInstanceFromRequirements requirements [] createInfo
: windowExtensions
)
Vk.createInstanceFromRequirements requirements [] createInfo
pickPhysicalDevice :: MonadResource m => Vk.Instance -> m Vk.PhysicalDevice data DeviceParams = DeviceParams
pickPhysicalDevice inst = do { dpDevicename :: T.Text
(_, devices) <- Vk.enumeratePhysicalDevices inst , dpPhysicalDevice :: Vk.PhysicalDevice
when (V.null devices) (error "Failed to find GPUs with Vulkan support") , dpDevice :: Vk.Device
mDevice <- V.foldM , dpGraphicsQueue :: Vk.Queue
(\acc dev -> do , dpGraphicsQueueFamilyIndex :: Word32
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
isDeviceSuitable :: MonadResource m => Vk.PhysicalDevice -> m Bool createDevice
isDeviceSuitable device = do :: MonadResource m
props <- Vk.getPhysicalDeviceProperties device => Vk.Instance
features <- Vk.getPhysicalDeviceFeatures device -> Vk.SurfaceKHR
queues <- isJust <$> findQueueFamilies device -> m DeviceParams
createDevice inst surface = do
(pdi, physDevice) <-
fromMaybe (error "Unable to find suitable physival device!") <$>
Vk.pickPhysicalDevice inst (physicalDeviceInfo surface) id
return devName <- Vk.physicalDeviceName physDevice
( Vk.deviceType props == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU &&
Vk.geometryShader features &&
queues
)
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
-- 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
-- --
-- get logical device
--
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
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

View file

@ -31,6 +31,7 @@ executable vulkan-tutorial
, sdl2 , sdl2
, vulkan , vulkan
, vulkan-utils , vulkan-utils
, VulkanMemoryAllocator
, linear , linear
, monad-loops , monad-loops
, stm , stm