get device set up properly

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
 
+  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
 
+  return $ DeviceParams
+    devName
+    physDevice
+    device
+    graphicsQueue
+    graphicsQueueFamilyIndex
 
--- 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
---   
+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

vulkan-tutorial.cabal

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