|
|
|
@ -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 |
|
|
|
|
|
|
|
|
|
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 |
|
|
|
|
|
|
|
|
|
isDeviceSuitable :: MonadResource m => Vk.PhysicalDevice -> m Bool |
|
|
|
|
isDeviceSuitable device = do |
|
|
|
|
props <- Vk.getPhysicalDeviceProperties device |
|
|
|
|
features <- Vk.getPhysicalDeviceFeatures device |
|
|
|
|
queues <- isJust <$> findQueueFamilies device |
|
|
|
|
|
|
|
|
|
return |
|
|
|
|
( 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 |
|
|
|
|
-- |
|
|
|
|
[Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ] |
|
|
|
|
Vk.createDebugInstanceFromRequirements requirements [] createInfo |
|
|
|
|
|
|
|
|
|
data DeviceParams = DeviceParams |
|
|
|
|
{ dpDevicename :: T.Text |
|
|
|
|
, dpPhysicalDevice :: Vk.PhysicalDevice |
|
|
|
|
, dpDevice :: Vk.Device |
|
|
|
|
, dpGraphicsQueue :: Vk.Queue |
|
|
|
|
, dpGraphicsQueueFamilyIndex :: Word32 |
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
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 |
|
|
|
|
|
|
|
|
|
devName <- Vk.physicalDeviceName physDevice |
|
|
|
|
|
|
|
|
|
-- |
|
|
|
|
-- 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 |
|
|
|
|