{-| A common physical-device + logical-device boot recipe: pick a device
that exposes a graphics/compute/transfer queue triple (with the graphics
family also presenting, when a surface is supplied), then create a logical
device with one 'Queue' allocated per slot.

This is the wheel every "draw a thing in Vulkan" application reinvents.
The recipe here is opinionated:

- The graphics slot doubles as the present queue.
- The compute slot prefers a compute-only queue family (async compute);
  falls back to aliasing the graphics family.
- The transfer slot prefers a transfer-only queue family (DMA-only
  hardware queue); falls back to aliasing the compute family.
- Priorities are 1.0 / 0.5 / 0.2 for graphics / compute / transfer.

When two slots target the same family, two distinct 'Queue' handles are
still allocated within that shared family with the requested priorities.

If you need a different shape (compute-only, multiple graphics queues,
custom priorities, …) reach for the lower-level
'Vulkan.Utils.QueueAssignment.assignQueues' directly.
-}
module Vulkan.Utils.Queues
  ( Queues (..)
  , allocateDevice
  ) where

import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Foldable (foldl', toList)
import Data.List (sortOn)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Traversable (mapAccumL)
import qualified Data.Vector as V
import Data.Word (Word32, Word64)
import Vulkan.CStruct.Extends (SomeStruct (..))
import qualified Vulkan.Core10 as Vk
import qualified Vulkan.Core10.DeviceInitialization as DI
import Vulkan.Extensions.VK_KHR_surface (SurfaceKHR)
import Vulkan.Requirement (DeviceRequirement)
import Vulkan.Utils.Initialization (allocateDeviceFromRequirements, pickPhysicalDevice)
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..), QueueSpec (..), assignQueues, isComputeQueueFamily, isGraphicsQueueFamily, isPresentQueueFamily, isTransferOnlyQueueFamily)
import Vulkan.Zero (zero)

{- | The G/C/T queue kit. Parametric in the slot contents so the same
shape can carry priorities ('Float'), family indices ('QueueFamilyIndex'),
queue specs ('QueueSpec'), or fully-resolved @(QueueFamilyIndex, Queue)@
pairs.
-}
data Queues a = Queues
  { forall a. Queues a -> a
qGraphics :: a
  -- ^ graphics + present, priority 1.0
  , forall a. Queues a -> a
qCompute :: a
  -- ^ compute (prefers compute-only family), priority 0.5
  , forall a. Queues a -> a
qTransfer :: a
  -- ^ transfer (prefers transfer-only family), priority 0.2
  }
  deriving (Int -> Queues a -> ShowS
[Queues a] -> ShowS
Queues a -> String
(Int -> Queues a -> ShowS)
-> (Queues a -> String) -> ([Queues a] -> ShowS) -> Show (Queues a)
forall a. Show a => Int -> Queues a -> ShowS
forall a. Show a => [Queues a] -> ShowS
forall a. Show a => Queues a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Queues a -> ShowS
showsPrec :: Int -> Queues a -> ShowS
$cshow :: forall a. Show a => Queues a -> String
show :: Queues a -> String
$cshowList :: forall a. Show a => [Queues a] -> ShowS
showList :: [Queues a] -> ShowS
Show, (forall a b. (a -> b) -> Queues a -> Queues b)
-> (forall a b. a -> Queues b -> Queues a) -> Functor Queues
forall a b. a -> Queues b -> Queues a
forall a b. (a -> b) -> Queues a -> Queues b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Queues a -> Queues b
fmap :: forall a b. (a -> b) -> Queues a -> Queues b
$c<$ :: forall a b. a -> Queues b -> Queues a
<$ :: forall a b. a -> Queues b -> Queues a
Functor, (forall m. Monoid m => Queues m -> m)
-> (forall m a. Monoid m => (a -> m) -> Queues a -> m)
-> (forall m a. Monoid m => (a -> m) -> Queues a -> m)
-> (forall a b. (a -> b -> b) -> b -> Queues a -> b)
-> (forall a b. (a -> b -> b) -> b -> Queues a -> b)
-> (forall b a. (b -> a -> b) -> b -> Queues a -> b)
-> (forall b a. (b -> a -> b) -> b -> Queues a -> b)
-> (forall a. (a -> a -> a) -> Queues a -> a)
-> (forall a. (a -> a -> a) -> Queues a -> a)
-> (forall a. Queues a -> [a])
-> (forall a. Queues a -> Bool)
-> (forall a. Queues a -> Int)
-> (forall a. Eq a => a -> Queues a -> Bool)
-> (forall a. Ord a => Queues a -> a)
-> (forall a. Ord a => Queues a -> a)
-> (forall a. Num a => Queues a -> a)
-> (forall a. Num a => Queues a -> a)
-> Foldable Queues
forall a. Eq a => a -> Queues a -> Bool
forall a. Num a => Queues a -> a
forall a. Ord a => Queues a -> a
forall m. Monoid m => Queues m -> m
forall a. Queues a -> Bool
forall a. Queues a -> Int
forall a. Queues a -> [a]
forall a. (a -> a -> a) -> Queues a -> a
forall m a. Monoid m => (a -> m) -> Queues a -> m
forall b a. (b -> a -> b) -> b -> Queues a -> b
forall a b. (a -> b -> b) -> b -> Queues a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Queues m -> m
fold :: forall m. Monoid m => Queues m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Queues a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Queues a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Queues a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Queues a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Queues a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Queues a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Queues a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Queues a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Queues a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Queues a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Queues a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Queues a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Queues a -> a
foldr1 :: forall a. (a -> a -> a) -> Queues a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Queues a -> a
foldl1 :: forall a. (a -> a -> a) -> Queues a -> a
$ctoList :: forall a. Queues a -> [a]
toList :: forall a. Queues a -> [a]
$cnull :: forall a. Queues a -> Bool
null :: forall a. Queues a -> Bool
$clength :: forall a. Queues a -> Int
length :: forall a. Queues a -> Int
$celem :: forall a. Eq a => a -> Queues a -> Bool
elem :: forall a. Eq a => a -> Queues a -> Bool
$cmaximum :: forall a. Ord a => Queues a -> a
maximum :: forall a. Ord a => Queues a -> a
$cminimum :: forall a. Ord a => Queues a -> a
minimum :: forall a. Ord a => Queues a -> a
$csum :: forall a. Num a => Queues a -> a
sum :: forall a. Num a => Queues a -> a
$cproduct :: forall a. Num a => Queues a -> a
product :: forall a. Num a => Queues a -> a
Foldable, Functor Queues
Foldable Queues
(Functor Queues, Foldable Queues) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Queues a -> f (Queues b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Queues (f a) -> f (Queues a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Queues a -> m (Queues b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Queues (m a) -> m (Queues a))
-> Traversable Queues
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Queues (m a) -> m (Queues a)
forall (f :: * -> *) a.
Applicative f =>
Queues (f a) -> f (Queues a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Queues a -> m (Queues b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Queues a -> f (Queues b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Queues a -> f (Queues b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Queues a -> f (Queues b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Queues (f a) -> f (Queues a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Queues (f a) -> f (Queues a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Queues a -> m (Queues b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Queues a -> m (Queues b)
$csequence :: forall (m :: * -> *) a. Monad m => Queues (m a) -> m (Queues a)
sequence :: forall (m :: * -> *) a. Monad m => Queues (m a) -> m (Queues a)
Traversable)

-- | Elementwise zip — handy for combining priorities with family predicates.
instance Applicative Queues where
  pure :: forall a. a -> Queues a
pure a
x = a -> a -> a -> Queues a
forall a. a -> a -> a -> Queues a
Queues a
x a
x a
x
  Queues a -> b
f a -> b
g a -> b
h <*> :: forall a b. Queues (a -> b) -> Queues a -> Queues b
<*> Queues a
x a
y a
z = b -> b -> b -> Queues b
forall a. a -> a -> a -> Queues a
Queues (a -> b
f a
x) (a -> b
g a
y) (a -> b
h a
z)

{- | Pick a physical device that has the queue families needed for the
caller, then create a logical device exposing one queue per G/C/T slot.
Devices are scored by total memory.

Pass @'Just' surface@ for windowed callers — the graphics family must also
support presentation. Pass 'Nothing' for headless callers — any graphics
family will do.

Pass any extra device requirements (extensions, features, API version) in
the third argument; they are forwarded to 'allocateDeviceFromRequirements'.

Fails (via 'MonadFail') when no physical device satisfies the family
requirements.
-}
allocateDevice
  :: (MonadResource m, MonadFail m)
  => Vk.Instance
  -> Maybe SurfaceKHR
  -> [DeviceRequirement]
  -> m (Vk.PhysicalDevice, Vk.Device, Queues (QueueFamilyIndex, Vk.Queue))
allocateDevice :: forall (m :: * -> *).
(MonadResource m, MonadFail m) =>
Instance
-> Maybe SurfaceKHR
-> [DeviceRequirement]
-> m (PhysicalDevice, Device, Queues (QueueFamilyIndex, Queue))
allocateDevice Instance
inst Maybe SurfaceKHR
mSurface [DeviceRequirement]
extraReqs = do
  mPd <-
    Instance
-> (PhysicalDevice -> m (Maybe (Queues QueueFamilyIndex, Word64)))
-> ((Queues QueueFamilyIndex, Word64) -> Word64)
-> m (Maybe ((Queues QueueFamilyIndex, Word64), PhysicalDevice))
forall (m :: * -> *) b a.
(MonadIO m, Ord b) =>
Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (Maybe (a, PhysicalDevice))
pickPhysicalDevice
      Instance
inst
      (Maybe SurfaceKHR
-> PhysicalDevice -> m (Maybe (Queues QueueFamilyIndex, Word64))
forall (m :: * -> *).
MonadIO m =>
Maybe SurfaceKHR
-> PhysicalDevice -> m (Maybe (Queues QueueFamilyIndex, Word64))
discoverFamilies Maybe SurfaceKHR
mSurface)
      ((Queues QueueFamilyIndex, Word64) -> Word64
forall a b. (a, b) -> b
snd :: (Queues QueueFamilyIndex, Word64) -> Word64)
  ((qFams, _score), phys) <- case mPd of
    Just ((Queues QueueFamilyIndex, Word64), PhysicalDevice)
x -> ((Queues QueueFamilyIndex, Word64), PhysicalDevice)
-> m ((Queues QueueFamilyIndex, Word64), PhysicalDevice)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Queues QueueFamilyIndex, Word64), PhysicalDevice)
x
    Maybe ((Queues QueueFamilyIndex, Word64), PhysicalDevice)
Nothing -> String -> m ((Queues QueueFamilyIndex, Word64), PhysicalDevice)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No physical device with the required G/C/T queue families"

  let
    prios = a -> a -> a -> Queues a
forall a. a -> a -> a -> Queues a
Queues a
1.0 a
0.5 a
0.2
    mkSpec QueueFamilyIndex
target Float
prio = Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
prio (\QueueFamilyIndex
i QueueFamilyProperties
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QueueFamilyIndex
i QueueFamilyIndex -> QueueFamilyIndex -> Bool
forall a. Eq a => a -> a -> Bool
== QueueFamilyIndex
target))
    specs = QueueFamilyIndex -> Float -> QueueSpec m
forall {m :: * -> *}.
Applicative m =>
QueueFamilyIndex -> Float -> QueueSpec m
mkSpec (QueueFamilyIndex -> Float -> QueueSpec m)
-> Queues QueueFamilyIndex -> Queues (Float -> QueueSpec m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Queues QueueFamilyIndex
qFams Queues (Float -> QueueSpec m)
-> Queues Float -> Queues (QueueSpec m)
forall a b. Queues (a -> b) -> Queues a -> Queues b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Queues Float
forall {a}. Fractional a => Queues a
prios

  -- Prefer 'assignQueues', which hands each slot its own queue for maximum
  -- parallelism. When the hardware can't supply that many distinct queues
  -- (e.g. a lone graphics+compute family exposing a single queue, as some
  -- mobile and translation-layer drivers do) fall back to sharing rather than
  -- failing: the triple still works, just with serialized submission.
  (qInfos, getQs) <-
    assignQueues phys specs >>= \case
      Just (Vector (DeviceQueueCreateInfo '[]),
 Device -> IO (Queues (QueueFamilyIndex, Queue)))
qs -> (Vector (DeviceQueueCreateInfo '[]),
 Device -> IO (Queues (QueueFamilyIndex, Queue)))
-> m (Vector (DeviceQueueCreateInfo '[]),
      Device -> IO (Queues (QueueFamilyIndex, Queue)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector (DeviceQueueCreateInfo '[]),
 Device -> IO (Queues (QueueFamilyIndex, Queue)))
qs
      Maybe
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> IO (Queues (QueueFamilyIndex, Queue)))
Nothing -> PhysicalDevice
-> Queues (QueueFamilyIndex, Float)
-> m (Vector (DeviceQueueCreateInfo '[]),
      Device -> IO (Queues (QueueFamilyIndex, Queue)))
forall (m :: * -> *).
MonadIO m =>
PhysicalDevice
-> Queues (QueueFamilyIndex, Float)
-> m (Vector (DeviceQueueCreateInfo '[]),
      Device -> IO (Queues (QueueFamilyIndex, Queue)))
shareQueues PhysicalDevice
phys ((,) (QueueFamilyIndex -> Float -> (QueueFamilyIndex, Float))
-> Queues QueueFamilyIndex
-> Queues (Float -> (QueueFamilyIndex, Float))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Queues QueueFamilyIndex
qFams Queues (Float -> (QueueFamilyIndex, Float))
-> Queues Float -> Queues (QueueFamilyIndex, Float)
forall a b. Queues (a -> b) -> Queues a -> Queues b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Queues Float
forall {a}. Fractional a => Queues a
prios)

  dev <-
    allocateDeviceFromRequirements
      extraReqs
      []
      phys
      zero{Vk.queueCreateInfos = SomeStruct <$> qInfos}
  qs <- liftIO (getQs dev)
  pure (phys, dev, qs)

discoverFamilies
  :: (MonadIO m)
  => Maybe SurfaceKHR
  -> Vk.PhysicalDevice
  -> m (Maybe (Queues QueueFamilyIndex, Word64))
discoverFamilies :: forall (m :: * -> *).
MonadIO m =>
Maybe SurfaceKHR
-> PhysicalDevice -> m (Maybe (Queues QueueFamilyIndex, Word64))
discoverFamilies Maybe SurfaceKHR
mSurf PhysicalDevice
phys = do
  qProps <- PhysicalDevice
-> m ("queueFamilyProperties" ::: Vector QueueFamilyProperties)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> io ("queueFamilyProperties" ::: Vector QueueFamilyProperties)
Vk.getPhysicalDeviceQueueFamilyProperties PhysicalDevice
phys
  let
    withIndex = Vector (Int, QueueFamilyProperties)
-> [(Int, QueueFamilyProperties)]
forall a. Vector a -> [a]
V.toList (("queueFamilyProperties" ::: Vector QueueFamilyProperties)
-> Vector (Int, QueueFamilyProperties)
forall a. Vector a -> Vector (Int, a)
V.indexed "queueFamilyProperties" ::: Vector QueueFamilyProperties
qProps)
    asQfi a
i = Word32 -> QueueFamilyIndex
QueueFamilyIndex (a -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i)

    graphicsFamilies =
      [Int -> QueueFamilyIndex
forall {a}. Integral a => a -> QueueFamilyIndex
asQfi Int
i | (Int
i, QueueFamilyProperties
q) <- [(Int, QueueFamilyProperties)]
withIndex, QueueFamilyProperties -> Bool
isGraphicsQueueFamily QueueFamilyProperties
q]
    asyncCompute =
      [ Int -> QueueFamilyIndex
forall {a}. Integral a => a -> QueueFamilyIndex
asQfi Int
i
      | (Int
i, QueueFamilyProperties
q) <- [(Int, QueueFamilyProperties)]
withIndex
      , QueueFamilyProperties -> Bool
isComputeQueueFamily QueueFamilyProperties
q Bool -> Bool -> Bool
&& Bool -> Bool
not (QueueFamilyProperties -> Bool
isGraphicsQueueFamily QueueFamilyProperties
q)
      ]
    anyCompute =
      [Int -> QueueFamilyIndex
forall {a}. Integral a => a -> QueueFamilyIndex
asQfi Int
i | (Int
i, QueueFamilyProperties
q) <- [(Int, QueueFamilyProperties)]
withIndex, QueueFamilyProperties -> Bool
isComputeQueueFamily QueueFamilyProperties
q]
    dedicatedTransfer =
      [Int -> QueueFamilyIndex
forall {a}. Integral a => a -> QueueFamilyIndex
asQfi Int
i | (Int
i, QueueFamilyProperties
q) <- [(Int, QueueFamilyProperties)]
withIndex, QueueFamilyProperties -> Bool
isTransferOnlyQueueFamily QueueFamilyProperties
q]

  mGp <- case mSurf of
    Just SurfaceKHR
surf -> do
      presentResults <-
        (QueueFamilyIndex -> m (QueueFamilyIndex, Bool))
-> [QueueFamilyIndex] -> m [(QueueFamilyIndex, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
          (\QueueFamilyIndex
qfi -> (QueueFamilyIndex
qfi,) (Bool -> (QueueFamilyIndex, Bool))
-> m Bool -> m (QueueFamilyIndex, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
isPresentQueueFamily PhysicalDevice
phys SurfaceKHR
surf QueueFamilyIndex
qfi)
          [QueueFamilyIndex]
graphicsFamilies
      pure $ case [qfi | (qfi, True) <- presentResults] of
        QueueFamilyIndex
qfi : [QueueFamilyIndex]
_ -> QueueFamilyIndex -> Maybe QueueFamilyIndex
forall a. a -> Maybe a
Just QueueFamilyIndex
qfi
        [] -> Maybe QueueFamilyIndex
forall a. Maybe a
Nothing
    Maybe SurfaceKHR
Nothing ->
      Maybe QueueFamilyIndex -> m (Maybe QueueFamilyIndex)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe QueueFamilyIndex -> m (Maybe QueueFamilyIndex))
-> Maybe QueueFamilyIndex -> m (Maybe QueueFamilyIndex)
forall a b. (a -> b) -> a -> b
$ case [QueueFamilyIndex]
graphicsFamilies of
        QueueFamilyIndex
qfi : [QueueFamilyIndex]
_ -> QueueFamilyIndex -> Maybe QueueFamilyIndex
forall a. a -> Maybe a
Just QueueFamilyIndex
qfi
        [] -> Maybe QueueFamilyIndex
forall a. Maybe a
Nothing

  let mCp = case [QueueFamilyIndex]
asyncCompute of
        QueueFamilyIndex
qfi : [QueueFamilyIndex]
_ -> QueueFamilyIndex -> Maybe QueueFamilyIndex
forall a. a -> Maybe a
Just QueueFamilyIndex
qfi
        [] -> case [QueueFamilyIndex]
anyCompute of
          QueueFamilyIndex
qfi : [QueueFamilyIndex]
_ -> QueueFamilyIndex -> Maybe QueueFamilyIndex
forall a. a -> Maybe a
Just QueueFamilyIndex
qfi
          [] -> Maybe QueueFamilyIndex
forall a. Maybe a
Nothing

  case (mGp, mCp) of
    (Just QueueFamilyIndex
gp, Just QueueFamilyIndex
cp) -> do
      let tf :: QueueFamilyIndex
tf = case [QueueFamilyIndex]
dedicatedTransfer of
            QueueFamilyIndex
qfi : [QueueFamilyIndex]
_ -> QueueFamilyIndex
qfi
            [] -> QueueFamilyIndex
cp
      heaps <- PhysicalDeviceMemoryProperties -> Vector MemoryHeap
Vk.memoryHeaps (PhysicalDeviceMemoryProperties -> Vector MemoryHeap)
-> m PhysicalDeviceMemoryProperties -> m (Vector MemoryHeap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice -> m PhysicalDeviceMemoryProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceMemoryProperties
Vk.getPhysicalDeviceMemoryProperties PhysicalDevice
phys
      let score = Vector Word64 -> Word64
forall a. Num a => Vector a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (MemoryHeap -> Word64
DI.size (MemoryHeap -> Word64) -> Vector MemoryHeap -> Vector Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector MemoryHeap
heaps) :: Word64
      pure (Just (Queues gp cp tf, score))
    (Maybe QueueFamilyIndex, Maybe QueueFamilyIndex)
_ -> Maybe (Queues QueueFamilyIndex, Word64)
-> m (Maybe (Queues QueueFamilyIndex, Word64))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Queues QueueFamilyIndex, Word64)
forall a. Maybe a
Nothing

{- | Robust fallback for 'allocateDevice' when 'assignQueues' can't give every
slot its own queue. Allocates as many distinct queues per family as the
hardware exposes, then aliases the surplus slots onto them round-robin, so it
always succeeds.

A shared queue keeps every capability it was selected for — a graphics+compute
family also handles transfer — so the result is correct, just less concurrent.
Two slots that resolve to the same 'Vk.Queue' compare equal, so a caller who
cares can detect aliasing. Callers submitting from multiple threads must
externally synchronize a shared queue themselves; see
'Vulkan.Utils.QueueAssignment'.
-}
shareQueues
  :: (MonadIO m)
  => Vk.PhysicalDevice
  -> Queues (QueueFamilyIndex, Float)
  -- ^ The resolved family and queue priority for each slot.
  -> m
       ( V.Vector (Vk.DeviceQueueCreateInfo '[])
       , Vk.Device -> IO (Queues (QueueFamilyIndex, Vk.Queue))
       )
shareQueues :: forall (m :: * -> *).
MonadIO m =>
PhysicalDevice
-> Queues (QueueFamilyIndex, Float)
-> m (Vector (DeviceQueueCreateInfo '[]),
      Device -> IO (Queues (QueueFamilyIndex, Queue)))
shareQueues PhysicalDevice
phys Queues (QueueFamilyIndex, Float)
famPrios = do
  capacities <- PhysicalDevice -> m (Map QueueFamilyIndex Word32)
forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> m (Map QueueFamilyIndex Word32)
familyCapacities PhysicalDevice
phys
  let
    capOf QueueFamilyIndex
fam = Word32 -> QueueFamilyIndex -> Map QueueFamilyIndex Word32 -> Word32
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Word32
0 QueueFamilyIndex
fam Map QueueFamilyIndex Word32
capacities

    -- Hand each slot a queue index within its family, wrapping at the family's
    -- capacity so surplus slots reuse (alias) earlier queues.
    step Map QueueFamilyIndex Word32
counts (QueueFamilyIndex
fam, Float
prio) =
      let
        used :: Word32
used = Word32 -> QueueFamilyIndex -> Map QueueFamilyIndex Word32 -> Word32
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Word32
0 QueueFamilyIndex
fam Map QueueFamilyIndex Word32
counts
        idx :: Word32
idx = Word32
used Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`mod` Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (QueueFamilyIndex -> Word32
capOf QueueFamilyIndex
fam)
      in
        (QueueFamilyIndex
-> Word32
-> Map QueueFamilyIndex Word32
-> Map QueueFamilyIndex Word32
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QueueFamilyIndex
fam (Word32
used Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1) Map QueueFamilyIndex Word32
counts, (QueueFamilyIndex
fam, Float
prio, Word32
idx))

    slots :: Queues (QueueFamilyIndex, Float, Word32)
    slots = (Map QueueFamilyIndex Word32,
 Queues (QueueFamilyIndex, Float, Word32))
-> Queues (QueueFamilyIndex, Float, Word32)
forall a b. (a, b) -> b
snd ((Map QueueFamilyIndex Word32
 -> (QueueFamilyIndex, Float)
 -> (Map QueueFamilyIndex Word32,
     (QueueFamilyIndex, Float, Word32)))
-> Map QueueFamilyIndex Word32
-> Queues (QueueFamilyIndex, Float)
-> (Map QueueFamilyIndex Word32,
    Queues (QueueFamilyIndex, Float, Word32))
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Map QueueFamilyIndex Word32
-> (QueueFamilyIndex, Float)
-> (Map QueueFamilyIndex Word32, (QueueFamilyIndex, Float, Word32))
step Map QueueFamilyIndex Word32
forall k a. Map k a
Map.empty Queues (QueueFamilyIndex, Float)
famPrios)

    -- The highest requested priority wins for a queue shared by several slots.
    priorityAt :: Map (QueueFamilyIndex, Word32) Float
    priorityAt =
      (Map (QueueFamilyIndex, Word32) Float
 -> (QueueFamilyIndex, Float, Word32)
 -> Map (QueueFamilyIndex, Word32) Float)
-> Map (QueueFamilyIndex, Word32) Float
-> [(QueueFamilyIndex, Float, Word32)]
-> Map (QueueFamilyIndex, Word32) Float
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        (\Map (QueueFamilyIndex, Word32) Float
acc (QueueFamilyIndex
fam, Float
prio, Word32
idx) -> (Float -> Float -> Float)
-> (QueueFamilyIndex, Word32)
-> Float
-> Map (QueueFamilyIndex, Word32) Float
-> Map (QueueFamilyIndex, Word32) Float
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Float -> Float -> Float
forall a. Ord a => a -> a -> a
max (QueueFamilyIndex
fam, Word32
idx) Float
prio Map (QueueFamilyIndex, Word32) Float
acc)
        Map (QueueFamilyIndex, Word32) Float
forall k a. Map k a
Map.empty
        (Queues (QueueFamilyIndex, Float, Word32)
-> [(QueueFamilyIndex, Float, Word32)]
forall a. Queues a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Queues (QueueFamilyIndex, Float, Word32)
slots)

    -- One create-info per family, priorities ordered by queue index.
    perFamily :: Map QueueFamilyIndex [(Word32, Float)]
    perFamily =
      ([(Word32, Float)] -> [(Word32, Float)] -> [(Word32, Float)])
-> [(QueueFamilyIndex, [(Word32, Float)])]
-> Map QueueFamilyIndex [(Word32, Float)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        [(Word32, Float)] -> [(Word32, Float)] -> [(Word32, Float)]
forall a. Semigroup a => a -> a -> a
(<>)
        [(QueueFamilyIndex
fam, [(Word32
idx, Float
prio)]) | ((QueueFamilyIndex
fam, Word32
idx), Float
prio) <- Map (QueueFamilyIndex, Word32) Float
-> [((QueueFamilyIndex, Word32), Float)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (QueueFamilyIndex, Word32) Float
priorityAt]

    createInfos =
      [DeviceQueueCreateInfo '[]] -> Vector (DeviceQueueCreateInfo '[])
forall a. [a] -> Vector a
V.fromList
        [ DeviceQueueCreateInfo '[]
forall a. Zero a => a
zero
            { Vk.queueFamilyIndex = unQueueFamilyIndex fam
            , Vk.queuePriorities = V.fromList (snd <$> sortOn fst idxPrios)
            }
        | (QueueFamilyIndex
fam, [(Word32, Float)]
idxPrios) <- Map QueueFamilyIndex [(Word32, Float)]
-> [(QueueFamilyIndex, [(Word32, Float)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map QueueFamilyIndex [(Word32, Float)]
perFamily
        ]

    getQueues Device
dev =
      ((QueueFamilyIndex, Float, Word32) -> f (QueueFamilyIndex, Queue))
-> Queues (QueueFamilyIndex, Float, Word32)
-> f (Queues (QueueFamilyIndex, Queue))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Queues a -> f (Queues b)
traverse
        ( \(QueueFamilyIndex
fam, Float
_, Word32
idx) ->
            (QueueFamilyIndex
fam,) (Queue -> (QueueFamilyIndex, Queue))
-> f Queue -> f (QueueFamilyIndex, Queue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Device -> Word32 -> Word32 -> f Queue
forall (io :: * -> *).
MonadIO io =>
Device -> Word32 -> Word32 -> io Queue
Vk.getDeviceQueue Device
dev (QueueFamilyIndex -> Word32
unQueueFamilyIndex QueueFamilyIndex
fam) Word32
idx
        )
        Queues (QueueFamilyIndex, Float, Word32)
slots

  pure (createInfos, getQueues)

-- | The number of queues each queue family of a 'Vk.PhysicalDevice' exposes.
familyCapacities
  :: (MonadIO m) => Vk.PhysicalDevice -> m (Map QueueFamilyIndex Word32)
familyCapacities :: forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> m (Map QueueFamilyIndex Word32)
familyCapacities PhysicalDevice
phys = do
  props <- PhysicalDevice
-> m ("queueFamilyProperties" ::: Vector QueueFamilyProperties)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> io ("queueFamilyProperties" ::: Vector QueueFamilyProperties)
Vk.getPhysicalDeviceQueueFamilyProperties PhysicalDevice
phys
  pure $
    Map.fromList
      [ (QueueFamilyIndex (fromIntegral i), Vk.queueCount qfp)
      | (i, qfp) <- zip [0 :: Int ..] (V.toList props)
      ]