-- | Physical device tools

module Engine.Setup.Device where

import RIO

import Control.Monad.Trans.Maybe (MaybeT(..))
import GHC.IO.Exception (IOException(..), IOErrorType(NoSuchThing))
import RIO.Vector qualified as V
import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Core11.Promoted_From_VK_KHR_multiview (PhysicalDeviceMultiviewFeatures(..))
import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing (PhysicalDeviceDescriptorIndexingFeatures(..))
import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore (PhysicalDeviceTimelineSemaphoreFeatures(..))
import Vulkan.CStruct.Extends ( SomeStruct(SomeStruct), pattern (:&), pattern (::&))
import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 (getPhysicalDeviceFeatures2KHR)
import Vulkan.Extensions.VK_KHR_surface qualified as Khr
import Vulkan.Extensions.VK_KHR_swapchain (pattern KHR_SWAPCHAIN_EXTENSION_NAME)
import Vulkan.Extensions.VK_KHR_timeline_semaphore (pattern KHR_TIMELINE_SEMAPHORE_EXTENSION_NAME)
import Vulkan.Utils.Initialization (createDeviceFromRequirements, physicalDeviceName, pickPhysicalDevice)
import Vulkan.Utils.QueueAssignment (QueueSpec(..))
import Vulkan.Utils.QueueAssignment qualified as Utils
import Vulkan.Utils.Requirements.TH qualified as Utils
import Vulkan.Core10 (PhysicalDeviceFeatures(..))
import Vulkan.Zero (zero)

import Engine.Vulkan.Types (PhysicalDeviceInfo(..), Queues(..))

allocatePhysical
  :: ( MonadUnliftIO m, MonadThrow m
     , MonadReader env m
     , HasLogFunc env
     , MonadResource m
     )
  => Vk.Instance
  -> Khr.SurfaceKHR
  -> (PhysicalDeviceInfo -> Word64)
  -> m (PhysicalDeviceInfo, Vk.PhysicalDevice)
allocatePhysical :: Instance
-> SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> m (PhysicalDeviceInfo, PhysicalDevice)
allocatePhysical Instance
vkInstance SurfaceKHR
surface PhysicalDeviceInfo -> Word64
score = do
  UnliftIO forall a. m a -> IO a
unliftIO <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO

  let
    create :: IO (PhysicalDeviceInfo, PhysicalDevice)
create = m (PhysicalDeviceInfo, PhysicalDevice)
-> IO (PhysicalDeviceInfo, PhysicalDevice)
forall a. m a -> IO a
unliftIO do
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Picking physical device..."
      Instance
-> (PhysicalDevice -> m (Maybe PhysicalDeviceInfo))
-> (PhysicalDeviceInfo -> Word64)
-> m (Maybe (PhysicalDeviceInfo, PhysicalDevice))
forall (m :: * -> *) b a.
(MonadIO m, Ord b) =>
Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (Maybe (a, PhysicalDevice))
pickPhysicalDevice Instance
vkInstance (SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo SurfaceKHR
surface) PhysicalDeviceInfo -> Word64
score m (Maybe (PhysicalDeviceInfo, PhysicalDevice))
-> (Maybe (PhysicalDeviceInfo, PhysicalDevice)
    -> m (PhysicalDeviceInfo, PhysicalDevice))
-> m (PhysicalDeviceInfo, PhysicalDevice)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (PhysicalDeviceInfo, PhysicalDevice)
Nothing ->
          String -> m (PhysicalDeviceInfo, PhysicalDevice)
forall (m :: * -> *) a. MonadThrow m => String -> m a
noSuchThing String
"Unable to find appropriate PhysicalDevice"
        Just res :: (PhysicalDeviceInfo, PhysicalDevice)
res@(PhysicalDeviceInfo
pdi, PhysicalDevice
_dev) -> do
          Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Utf8Builder
"Using physical device: "
            , Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (PhysicalDeviceInfo -> Text
pdiName PhysicalDeviceInfo
pdi)
            ]
          pure (PhysicalDeviceInfo, PhysicalDevice)
res

    destroy :: (PhysicalDeviceInfo, PhysicalDevice) -> IO ()
destroy (PhysicalDeviceInfo, PhysicalDevice)
_res = m () -> IO ()
forall a. m a -> IO a
unliftIO (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Destroying physical device"

  ((ReleaseKey, (PhysicalDeviceInfo, PhysicalDevice))
 -> (PhysicalDeviceInfo, PhysicalDevice))
-> m (ReleaseKey, (PhysicalDeviceInfo, PhysicalDevice))
-> m (PhysicalDeviceInfo, PhysicalDevice)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, (PhysicalDeviceInfo, PhysicalDevice))
-> (PhysicalDeviceInfo, PhysicalDevice)
forall a b. (a, b) -> b
snd (m (ReleaseKey, (PhysicalDeviceInfo, PhysicalDevice))
 -> m (PhysicalDeviceInfo, PhysicalDevice))
-> m (ReleaseKey, (PhysicalDeviceInfo, PhysicalDevice))
-> m (PhysicalDeviceInfo, PhysicalDevice)
forall a b. (a -> b) -> a -> b
$ IO (PhysicalDeviceInfo, PhysicalDevice)
-> ((PhysicalDeviceInfo, PhysicalDevice) -> IO ())
-> m (ReleaseKey, (PhysicalDeviceInfo, PhysicalDevice))
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate IO (PhysicalDeviceInfo, PhysicalDevice)
create (PhysicalDeviceInfo, PhysicalDevice) -> IO ()
destroy

physicalDeviceInfo
  :: ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     )
  => Khr.SurfaceKHR -> Vk.PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo :: SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo SurfaceKHR
surf PhysicalDevice
phys = MaybeT m PhysicalDeviceInfo -> m (Maybe PhysicalDeviceInfo)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  Text
pdiName <- PhysicalDevice -> MaybeT m Text
forall (m :: * -> *). MonadIO m => PhysicalDevice -> m Text
physicalDeviceName PhysicalDevice
phys
  Utf8Builder -> MaybeT m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> MaybeT m ()) -> Utf8Builder -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Considering " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Text
pdiName

  Bool
hasTimelineSemaphores <- PhysicalDevice -> MaybeT m Bool
forall (m :: * -> *). MonadIO m => PhysicalDevice -> m Bool
deviceHasTimelineSemaphores PhysicalDevice
phys
  Bool -> MaybeT m () -> MaybeT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasTimelineSemaphores do
    Utf8Builder -> MaybeT m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> MaybeT m ()) -> Utf8Builder -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
      [ Utf8Builder
"Not using physical device "
      , Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Text
pdiName
      , Utf8Builder
" because it doesn't support timeline semaphores"
      ]

  Bool
hasSwapchainSupport <- PhysicalDevice -> MaybeT m Bool
forall (m :: * -> *). MonadIO m => PhysicalDevice -> m Bool
deviceHasSwapchain PhysicalDevice
phys
  Bool -> MaybeT m () -> MaybeT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasSwapchainSupport do
    Utf8Builder -> MaybeT m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> MaybeT m ()) -> Utf8Builder -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
      [ Utf8Builder
"Not using physical device "
      , Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Text
pdiName
      , Utf8Builder
" because it doesn't support swapchains"
      ]

  (Vector (DeviceQueueCreateInfo '[])
pdiQueueCreateInfos, Device -> IO (Queues (QueueFamilyIndex, Queue))
pdiGetQueues) <- m (Maybe
     (Vector (DeviceQueueCreateInfo '[]),
      Device -> IO (Queues (QueueFamilyIndex, Queue))))
-> MaybeT
     m
     (Vector (DeviceQueueCreateInfo '[]),
      Device -> IO (Queues (QueueFamilyIndex, Queue)))
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe
      (Vector (DeviceQueueCreateInfo '[]),
       Device -> IO (Queues (QueueFamilyIndex, Queue))))
 -> MaybeT
      m
      (Vector (DeviceQueueCreateInfo '[]),
       Device -> IO (Queues (QueueFamilyIndex, Queue))))
-> m (Maybe
        (Vector (DeviceQueueCreateInfo '[]),
         Device -> IO (Queues (QueueFamilyIndex, Queue))))
-> MaybeT
     m
     (Vector (DeviceQueueCreateInfo '[]),
      Device -> IO (Queues (QueueFamilyIndex, Queue)))
forall a b. (a -> b) -> a -> b
$
    PhysicalDevice
-> Queues (QueueSpec m)
-> m (Maybe
        (Vector (DeviceQueueCreateInfo '[]),
         Device -> IO (Queues (QueueFamilyIndex, Queue))))
forall (f :: * -> *) (m :: * -> *) (n :: * -> *).
(Traversable f, MonadIO m, MonadIO n) =>
PhysicalDevice
-> f (QueueSpec m)
-> m (Maybe
        (Vector (DeviceQueueCreateInfo '[]),
         Device -> n (f (QueueFamilyIndex, Queue))))
Utils.assignQueues PhysicalDevice
phys (PhysicalDevice -> SurfaceKHR -> Queues (QueueSpec m)
forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> SurfaceKHR -> Queues (QueueSpec m)
queueRequirements PhysicalDevice
phys SurfaceKHR
surf)

  Word64
pdiTotalMemory <- do
    PhysicalDeviceMemoryProperties
props <- PhysicalDevice -> MaybeT m PhysicalDeviceMemoryProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceMemoryProperties
Vk.getPhysicalDeviceMemoryProperties PhysicalDevice
phys
    Word64 -> MaybeT m Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> MaybeT m Word64)
-> (Vector Word64 -> Word64) -> Vector Word64 -> MaybeT m Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word64 -> Word64
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Vector Word64 -> MaybeT m Word64)
-> Vector Word64 -> MaybeT m Word64
forall a b. (a -> b) -> a -> b
$
      (MemoryHeap -> Word64) -> Vector MemoryHeap -> Vector Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (MemoryHeap -> Word64
Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize)
        (PhysicalDeviceMemoryProperties -> Vector MemoryHeap
Vk.memoryHeaps PhysicalDeviceMemoryProperties
props)

  PhysicalDeviceProperties
pdiProperties <- PhysicalDevice -> MaybeT m PhysicalDeviceProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceProperties
Vk.getPhysicalDeviceProperties PhysicalDevice
phys

  pure PhysicalDeviceInfo :: Word64
-> Vector (DeviceQueueCreateInfo '[])
-> Text
-> PhysicalDeviceProperties
-> (Device -> IO (Queues (QueueFamilyIndex, Queue)))
-> PhysicalDeviceInfo
PhysicalDeviceInfo{Word64
Text
Vector (DeviceQueueCreateInfo '[])
PhysicalDeviceProperties
Device -> IO (Queues (QueueFamilyIndex, Queue))
$sel:pdiGetQueues:PhysicalDeviceInfo :: Device -> IO (Queues (QueueFamilyIndex, Queue))
$sel:pdiProperties:PhysicalDeviceInfo :: PhysicalDeviceProperties
$sel:pdiQueueCreateInfos:PhysicalDeviceInfo :: Vector (DeviceQueueCreateInfo '[])
$sel:pdiTotalMemory:PhysicalDeviceInfo :: Word64
pdiProperties :: PhysicalDeviceProperties
pdiTotalMemory :: Word64
pdiGetQueues :: Device -> IO (Queues (QueueFamilyIndex, Queue))
pdiQueueCreateInfos :: Vector (DeviceQueueCreateInfo '[])
pdiName :: Text
$sel:pdiName:PhysicalDeviceInfo :: Text
..}

{- |
  Requirements for a 'Queue' which has graphics support and can present to
  the specified surface.

  Priorities are ranged 0.0 to 1.0 with higher number means higher priority.
  https://www.khronos.org/registry/vulkan/specs/1.2-extensions/html/vkspec.html#devsandqueues-priority
-}
queueRequirements
  :: MonadIO m
  => Vk.PhysicalDevice -> Khr.SurfaceKHR -> Queues (QueueSpec m)
queueRequirements :: PhysicalDevice -> SurfaceKHR -> Queues (QueueSpec m)
queueRequirements PhysicalDevice
phys SurfaceKHR
surf = Queues :: forall q. q -> q -> q -> Queues q
Queues
  { $sel:qGraphics:Queues :: QueueSpec m
qGraphics = Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
1.0 QueueFamilyIndex -> QueueFamilyProperties -> m Bool
isGraphicsPresentQueue
  , $sel:qCompute:Queues :: QueueSpec m
qCompute  = Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
0.5 QueueFamilyIndex -> QueueFamilyProperties -> m Bool
forall (f :: * -> *) p.
Applicative f =>
p -> QueueFamilyProperties -> f Bool
isComputeQueue
  , $sel:qTransfer:Queues :: QueueSpec m
qTransfer = Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
0.0 QueueFamilyIndex -> QueueFamilyProperties -> m Bool
forall (f :: * -> *) p.
Applicative f =>
p -> QueueFamilyProperties -> f Bool
isTransferQueue
  }
 where
  isGraphicsPresentQueue :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool
isGraphicsPresentQueue QueueFamilyIndex
queueFamilyIndex QueueFamilyProperties
queueFamilyProperties = do
    Bool
pq <- PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
Utils.isPresentQueueFamily PhysicalDevice
phys SurfaceKHR
surf QueueFamilyIndex
queueFamilyIndex
    let gq :: Bool
gq = QueueFamilyProperties -> Bool
Utils.isGraphicsQueueFamily QueueFamilyProperties
queueFamilyProperties
    Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool
pq Bool -> Bool -> Bool
&& Bool
gq

  isTransferQueue :: p -> QueueFamilyProperties -> f Bool
isTransferQueue p
_queueFamilyIndex QueueFamilyProperties
queueFamilyProperties =
    Bool -> f Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> f Bool) -> Bool -> f Bool
forall a b. (a -> b) -> a -> b
$ QueueFamilyProperties -> Bool
Utils.isTransferQueueFamily QueueFamilyProperties
queueFamilyProperties

  isComputeQueue :: p -> QueueFamilyProperties -> f Bool
isComputeQueue p
_queueFamilyIndex QueueFamilyProperties
queueFamilyProperties =
    Bool -> f Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> f Bool) -> Bool -> f Bool
forall a b. (a -> b) -> a -> b
$ QueueFamilyProperties -> Bool
Utils.isComputeQueueFamily QueueFamilyProperties
queueFamilyProperties

deviceHasSwapchain :: MonadIO m => Vk.PhysicalDevice -> m Bool
deviceHasSwapchain :: PhysicalDevice -> m Bool
deviceHasSwapchain PhysicalDevice
dev = do
  (Result
_, "properties" ::: Vector ExtensionProperties
extensions) <- PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> io (Result, "properties" ::: Vector ExtensionProperties)
Vk.enumerateDeviceExtensionProperties PhysicalDevice
dev "layerName" ::: Maybe ByteString
forall a. Maybe a
Nothing
  Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (ExtensionProperties -> Bool)
-> ("properties" ::: Vector ExtensionProperties) -> Bool
forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> Bool
V.any
    ((ByteString
forall a. (Eq a, IsString a) => a
KHR_SWAPCHAIN_EXTENSION_NAME ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool)
-> (ExtensionProperties -> ByteString)
-> ExtensionProperties
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtensionProperties -> ByteString
Vk.extensionName)
    "properties" ::: Vector ExtensionProperties
extensions

deviceHasTimelineSemaphores :: MonadIO m => Vk.PhysicalDevice -> m Bool
deviceHasTimelineSemaphores :: PhysicalDevice -> m Bool
deviceHasTimelineSemaphores PhysicalDevice
phys = do
  (Result
_, "properties" ::: Vector ExtensionProperties
extensions) <- PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> m (Result, "properties" ::: Vector ExtensionProperties)
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice
-> ("layerName" ::: Maybe ByteString)
-> io (Result, "properties" ::: Vector ExtensionProperties)
Vk.enumerateDeviceExtensionProperties PhysicalDevice
phys "layerName" ::: Maybe ByteString
forall a. Maybe a
Nothing
  let
    hasExt :: Bool
hasExt = (ExtensionProperties -> Bool)
-> ("properties" ::: Vector ExtensionProperties) -> Bool
forall (v :: * -> *) a. Vector v a => (a -> Bool) -> v a -> Bool
V.any
      ((ByteString
forall a. (Eq a, IsString a) => a
KHR_TIMELINE_SEMAPHORE_EXTENSION_NAME ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool)
-> (ExtensionProperties -> ByteString)
-> ExtensionProperties
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtensionProperties -> ByteString
Vk.extensionName)
      "properties" ::: Vector ExtensionProperties
extensions

  Bool
hasFeat <- PhysicalDevice
-> m (PhysicalDeviceFeatures2
        '[PhysicalDeviceTimelineSemaphoreFeatures])
forall (a :: [*]) (io :: * -> *).
(Extendss PhysicalDeviceFeatures2 a, PokeChain a, PeekChain a,
 MonadIO io) =>
PhysicalDevice -> io (PhysicalDeviceFeatures2 a)
getPhysicalDeviceFeatures2KHR PhysicalDevice
phys m (PhysicalDeviceFeatures2
     '[PhysicalDeviceTimelineSemaphoreFeatures])
-> (PhysicalDeviceFeatures2
      '[PhysicalDeviceTimelineSemaphoreFeatures]
    -> m Bool)
-> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PhysicalDeviceFeatures2 es'
_ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) ->
      Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
hasTimelineSemaphores
    PhysicalDeviceFeatures2 '[PhysicalDeviceTimelineSemaphoreFeatures]
_ ->
      Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  pure $ Bool
hasExt Bool -> Bool -> Bool
&& Bool
hasFeat

allocateLogical
  :: ( MonadUnliftIO m
     , MonadReader env m, HasLogFunc env
     , MonadResource m
     )
  => PhysicalDeviceInfo -> Vk.PhysicalDevice -> m Vk.Device
allocateLogical :: PhysicalDeviceInfo -> PhysicalDevice -> m Device
allocateLogical PhysicalDeviceInfo
pdi PhysicalDevice
pd = do
  Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Creating logical device"

  Device
ld <- [DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
forall (m :: * -> *).
MonadResource m =>
[DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
createDeviceFromRequirements
    [Utils.reqs|
      1.2

      VK_KHR_maintenance3
      VK_KHR_swapchain

      -- PhysicalDeviceFeatures.robustBufferAccess
      PhysicalDeviceFeatures.textureCompressionBC

      VK_KHR_multiview
      PhysicalDeviceMultiviewFeatures.multiview

      VK_EXT_descriptor_indexing
      PhysicalDeviceDescriptorIndexingFeatures.descriptorBindingPartiallyBound
      PhysicalDeviceDescriptorIndexingFeatures.descriptorBindingVariableDescriptorCount
      PhysicalDeviceDescriptorIndexingFeatures.runtimeDescriptorArray
      PhysicalDeviceDescriptorIndexingFeatures.shaderSampledImageArrayNonUniformIndexing

      VK_KHR_timeline_semaphore
      PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore
    |]
    [Utils.reqs|
      PhysicalDeviceFeatures.samplerAnisotropy
      PhysicalDeviceFeatures.sampleRateShading
    |]
    PhysicalDevice
pd
    DeviceCreateInfo '[]
deviceCI

  m () -> m (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Destroying logical device") m (IO ()) -> (IO () -> m ReleaseKey) -> m ReleaseKey
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register

  pure Device
ld

  where
    deviceCI :: DeviceCreateInfo '[]
deviceCI = DeviceCreateInfo '[]
forall a. Zero a => a
zero
      { $sel:queueCreateInfos:DeviceCreateInfo :: Vector (SomeStruct DeviceQueueCreateInfo)
Vk.queueCreateInfos = (DeviceQueueCreateInfo '[] -> SomeStruct DeviceQueueCreateInfo)
-> Vector (DeviceQueueCreateInfo '[])
-> Vector (SomeStruct DeviceQueueCreateInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeviceQueueCreateInfo '[] -> SomeStruct DeviceQueueCreateInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct (PhysicalDeviceInfo -> Vector (DeviceQueueCreateInfo '[])
pdiQueueCreateInfos PhysicalDeviceInfo
pdi)
      }

noSuchThing :: MonadThrow m => String -> m a
noSuchThing :: String -> m a
noSuchThing String
message =
  IOException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (IOException -> m a) -> IOException -> m a
forall a b. (a -> b) -> a -> b
$
    Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
NoSuchThing String
"" String
message Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing