{-# LANGUAGE OverloadedRecordDot #-}
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 <- 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 (Maybe SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Maybe SurfaceKHR -> PhysicalDevice -> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo Maybe SurfaceKHR
presentSurface) PhysicalDeviceInfo -> Word64
score m (Maybe (PhysicalDeviceInfo, PhysicalDevice))
-> (Maybe (PhysicalDeviceInfo, PhysicalDevice)
-> m (PhysicalDeviceInfo, PhysicalDevice))
-> m (PhysicalDeviceInfo, PhysicalDevice)
forall a b. m a -> (a -> m b) -> m b
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 a b. (a -> b) -> m a -> m b
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
)
=> 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 = 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
let
ignoreDevice :: Bool
ignoreDevice =
Text
"llvmpipe" Text -> Text -> Bool
`Text.isPrefixOf` Text
pdiName
if Bool
ignoreDevice then do
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
"Ignoring " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Text
pdiName
MaybeT m ()
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
else
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"
]
MaybeT m ()
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
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"
]
MaybeT m ()
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
Maybe
(Vector (DeviceQueueCreateInfo '[]),
Device -> IO (Queues (QueueFamilyIndex, Queue)))
assigned <- PhysicalDevice
-> Queues (QueueSpec (MaybeT m))
-> MaybeT
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 -> Maybe SurfaceKHR -> Queues (QueueSpec (MaybeT m))
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
Utf8Builder -> MaybeT m ()
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 (QueueSpec (MaybeT m) -> Identity (QueueSpec (MaybeT m))
forall a. a -> Identity a
Identity (QueueSpec (MaybeT m) -> Identity (QueueSpec (MaybeT m)))
-> QueueSpec (MaybeT m) -> Identity (QueueSpec (MaybeT m))
forall a b. (a -> b) -> a -> b
$ Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> MaybeT m Bool)
-> QueueSpec (MaybeT m)
forall (m :: * -> *).
Float
-> (QueueFamilyIndex -> QueueFamilyProperties -> m Bool)
-> QueueSpec m
QueueSpec Float
1.0 QueueFamilyIndex -> QueueFamilyProperties -> MaybeT m Bool
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
Utf8Builder -> MaybeT m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Fallback assignment failed too"
MaybeT
m
(Vector (DeviceQueueCreateInfo '[]),
Device -> IO (Queues (QueueFamilyIndex, Queue)))
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
Just (Vector (DeviceQueueCreateInfo '[])
infos, Device -> IO (Identity (QueueFamilyIndex, Queue))
getQueues) -> do
Utf8Builder -> MaybeT m ()
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
Queues (QueueFamilyIndex, Queue)
-> IO (Queues (QueueFamilyIndex, Queue))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Queues (QueueFamilyIndex, Queue)
-> IO (Queues (QueueFamilyIndex, Queue)))
-> Queues (QueueFamilyIndex, Queue)
-> IO (Queues (QueueFamilyIndex, Queue))
forall a b. (a -> b) -> a -> b
$ (QueueFamilyIndex, Queue)
-> (QueueFamilyIndex, Queue)
-> (QueueFamilyIndex, Queue)
-> Queues (QueueFamilyIndex, Queue)
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 ->
(Vector (DeviceQueueCreateInfo '[]),
Device -> IO (Queues (QueueFamilyIndex, Queue)))
-> MaybeT
m
(Vector (DeviceQueueCreateInfo '[]),
Device -> IO (Queues (QueueFamilyIndex, Queue)))
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector (DeviceQueueCreateInfo '[]),
Device -> IO (Queues (QueueFamilyIndex, Queue)))
queues
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 a. a -> MaybeT m a
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 a. Num a => Vector a -> a
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 a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.size) (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
Text
Vector (DeviceQueueCreateInfo '[])
PhysicalDeviceProperties
Device -> IO (Queues (QueueFamilyIndex, Queue))
$sel:pdiName:PhysicalDeviceInfo :: Text
pdiName :: Text
pdiQueueCreateInfos :: Vector (DeviceQueueCreateInfo '[])
pdiGetQueues :: Device -> IO (Queues (QueueFamilyIndex, Queue))
pdiTotalMemory :: Word64
pdiProperties :: PhysicalDeviceProperties
$sel:pdiTotalMemory:PhysicalDeviceInfo :: Word64
$sel:pdiQueueCreateInfos:PhysicalDeviceInfo :: Vector (DeviceQueueCreateInfo '[])
$sel:pdiProperties:PhysicalDeviceInfo :: PhysicalDeviceProperties
$sel:pdiGetQueues:PhysicalDeviceInfo :: Device -> IO (Queues (QueueFamilyIndex, Queue))
..}
where
isFallbackQ :: p -> QueueFamilyProperties -> f Bool
isFallbackQ p
_queueFamilyIndex QueueFamilyProperties
queueFamilyProperties =
Bool -> f Bool
forall a. a -> f a
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.isGraphicsQueueFamily QueueFamilyProperties
queueFamilyProperties
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 = 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 =
case Maybe SurfaceKHR
presentSurface of
Just SurfaceKHR
surf -> 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
pure $ Bool
pq Bool -> Bool -> Bool
&& Bool
gq
Maybe SurfaceKHR
Nothing ->
Bool -> m Bool
forall a. a -> m a
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 =
Bool -> f Bool
forall a. a -> f a
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 a. a -> f a
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 :: forall (m :: * -> *). MonadIO m => 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 a. a -> m a
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 -> 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 :: forall (m :: * -> *). MonadIO m => 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 -> 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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
PhysicalDeviceFeatures2 es'
_ ::& (PhysicalDeviceTimelineSemaphoreFeatures Bool
hasTimelineSemaphores :& ()) ->
Bool -> m Bool
forall a. a -> m a
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
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
[DeviceRequirement]
[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
|]
[DeviceRequirement]
[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 a b. m a -> (a -> m b) -> m b
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 a b. (a -> b) -> Vector a -> Vector b
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 :: forall (m :: * -> *) a. MonadThrow m => String -> m a
noSuchThing String
message =
IOException -> m a
forall e a. Exception e => e -> 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