{-# LANGUAGE OverloadedRecordDot #-}

-- | 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.Text qualified as Text
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
  -> Maybe Khr.SurfaceKHR
  -> (PhysicalDeviceInfo -> Word64)
  -> m (PhysicalDeviceInfo, Vk.PhysicalDevice)
allocatePhysical :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadThrow m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Instance
-> Maybe SurfaceKHR
-> (PhysicalDeviceInfo -> Word64)
-> m (PhysicalDeviceInfo, PhysicalDevice)
allocatePhysical Instance
vkInstance Maybe SurfaceKHR
presentSurface PhysicalDeviceInfo -> Word64
score = do
  UnliftIO forall a. m a -> IO a
unliftIO <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO

  let
    create :: IO (PhysicalDeviceInfo, PhysicalDevice)
create = forall a. m a -> IO a
unliftIO do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Picking physical device..."
      forall (m :: * -> *) b a.
(MonadIO m, Ord b) =>
Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (Maybe (a, PhysicalDevice))
pickPhysicalDevice Instance
vkInstance (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Maybe SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo Maybe SurfaceKHR
presentSurface) PhysicalDeviceInfo -> Word64
score forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (PhysicalDeviceInfo, PhysicalDevice)
Nothing ->
          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
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ Utf8Builder
"Using physical device: "
            , forall a. Show a => a -> Utf8Builder
displayShow (PhysicalDeviceInfo -> Text
pdiName PhysicalDeviceInfo
pdi)
            ]
          pure (PhysicalDeviceInfo, PhysicalDevice)
res

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

  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ 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
     )
  => Maybe Khr.SurfaceKHR
  -> Vk.PhysicalDevice
  -> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Maybe SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo Maybe SurfaceKHR
presentSurface PhysicalDevice
phys = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
  Text
pdiName <- forall (m :: * -> *). MonadIO m => PhysicalDevice -> m Text
physicalDeviceName PhysicalDevice
phys

  let
    ignoreDevice :: Bool
ignoreDevice =
      Text
"llvmpipe" Text -> Text -> Bool
`Text.isPrefixOf` Text
pdiName

  if Bool
ignoreDevice then do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Ignoring " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Text
pdiName
    forall (m :: * -> *) a. MonadPlus m => m a
mzero
  else
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Considering " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Text
pdiName

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

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

  Maybe
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> IO (Queues (QueueFamilyIndex, Queue)))
assigned <- 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 (forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> Maybe SurfaceKHR -> Queues (QueueSpec m)
queueRequirements PhysicalDevice
phys Maybe SurfaceKHR
presentSurface)
  (Vector (DeviceQueueCreateInfo '[])
pdiQueueCreateInfos, Device -> IO (Queues (QueueFamilyIndex, Queue))
pdiGetQueues) <- case Maybe
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> IO (Queues (QueueFamilyIndex, Queue)))
assigned of
    Maybe
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> IO (Queues (QueueFamilyIndex, Queue)))
Nothing -> do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Queue assignment failed"
      Maybe
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> IO (Identity (QueueFamilyIndex, Queue)))
fallback <- 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 @_ @_ @IO PhysicalDevice
phys (forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
1.0 forall {f :: * -> *} {p}.
Applicative f =>
p -> QueueFamilyProperties -> f Bool
isFallbackQ)
      case Maybe
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> IO (Identity (QueueFamilyIndex, Queue)))
fallback of
        Maybe
  (Vector (DeviceQueueCreateInfo '[]),
   Device -> IO (Identity (QueueFamilyIndex, Queue)))
Nothing -> do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Fallback assignment failed too"
          forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Just (Vector (DeviceQueueCreateInfo '[])
infos, Device -> IO (Identity (QueueFamilyIndex, Queue))
getQueues) -> do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Fallback assignment succeeded"
          pure
            ( Vector (DeviceQueueCreateInfo '[])
infos
            , \Device
dev -> do
                Identity (QueueFamilyIndex, Queue)
q <- Device -> IO (Identity (QueueFamilyIndex, Queue))
getQueues Device
dev
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall q. q -> q -> q -> Queues q
Queues (QueueFamilyIndex, Queue)
q (QueueFamilyIndex, Queue)
q (QueueFamilyIndex, Queue)
q
            )

    Just (Vector (DeviceQueueCreateInfo '[]),
 Device -> IO (Queues (QueueFamilyIndex, Queue)))
queues ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector (DeviceQueueCreateInfo '[]),
 Device -> IO (Queues (QueueFamilyIndex, Queue)))
queues

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

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

  pure 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
..}
  where
    isFallbackQ :: p -> QueueFamilyProperties -> f Bool
isFallbackQ p
_queueFamilyIndex QueueFamilyProperties
queueFamilyProperties =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ QueueFamilyProperties -> Bool
Utils.isGraphicsQueueFamily QueueFamilyProperties
queueFamilyProperties

{- |
  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
  -> Maybe Khr.SurfaceKHR
  -> Queues (QueueSpec m)
queueRequirements :: forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> Maybe SurfaceKHR -> Queues (QueueSpec m)
queueRequirements PhysicalDevice
phys Maybe SurfaceKHR
presentSurface = Queues
  { $sel:qGraphics:Queues :: QueueSpec m
qGraphics = forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
1.0 QueueFamilyIndex -> QueueFamilyProperties -> m Bool
isGraphicsPresentQueue
  , $sel:qCompute:Queues :: QueueSpec m
qCompute  = forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
0.5 forall {f :: * -> *} {p}.
Applicative f =>
p -> QueueFamilyProperties -> f Bool
isComputeQueue
  , $sel:qTransfer:Queues :: QueueSpec m
qTransfer = forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
0.0 forall {f :: * -> *} {p}.
Applicative f =>
p -> QueueFamilyProperties -> f Bool
isTransferQueue
  }
 where
  isGraphicsPresentQueue :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool
isGraphicsPresentQueue QueueFamilyIndex
queueFamilyIndex QueueFamilyProperties
queueFamilyProperties =
    case Maybe SurfaceKHR
presentSurface of
      Just SurfaceKHR
surf -> do
        Bool
pq <- forall (m :: * -> *).
MonadIO m =>
PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool
Utils.isPresentQueueFamily PhysicalDevice
phys SurfaceKHR
surf QueueFamilyIndex
queueFamilyIndex
        pure $ Bool
pq Bool -> Bool -> Bool
&& Bool
gq
      Maybe SurfaceKHR
Nothing ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
gq
    where
      gq :: Bool
gq = QueueFamilyProperties -> Bool
Utils.isGraphicsQueueFamily QueueFamilyProperties
queueFamilyProperties

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

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

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

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

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

  Device
ld <- 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

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

  pure Device
ld

  where
    deviceCI :: DeviceCreateInfo '[]
deviceCI = forall a. Zero a => a
zero
      { $sel:queueCreateInfos:DeviceCreateInfo :: Vector (SomeStruct DeviceQueueCreateInfo)
Vk.queueCreateInfos = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 :: forall (m :: * -> *) a. MonadThrow m => String -> m a
noSuchThing String
message =
  forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
    Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError forall a. Maybe a
Nothing IOErrorType
NoSuchThing String
"" String
message forall a. Maybe a
Nothing forall a. Maybe a
Nothing