{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
module Vulkan.Utils.Initialization
(
allocateInstanceFromRequirements
, allocateDebugInstanceFromRequirements
, allocateVulkanInstance
, portabilityRequirements
, portabilityFlags
, devicePortabilityRequirements
, allocateDeviceFromRequirements
, pickPhysicalDevice
, physicalDeviceName
, createInstanceFromRequirements
, createDebugInstanceFromRequirements
, createDeviceFromRequirements
) where
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Bits
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Maybe
import Data.Ord
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Vector (Vector)
import Vulkan.CStruct.Extends
import Vulkan.Core10
import qualified Vulkan.Core10 as Instance (InstanceCreateInfo (..))
import Vulkan.Extensions.VK_EXT_debug_utils
import Vulkan.Extensions.VK_EXT_validation_features
import Vulkan.Requirement
import Vulkan.Utils.Debug
import Vulkan.Utils.Internal
import Vulkan.Utils.Requirements
import Vulkan.Zero
#if defined(darwin_HOST_OS)
import Vulkan.Core10.Enums.InstanceCreateFlagBits
( pattern INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR )
import Vulkan.Extensions.VK_KHR_portability_enumeration
( pattern KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME )
import Vulkan.Extensions.VK_KHR_portability_subset
( pattern KHR_PORTABILITY_SUBSET_EXTENSION_NAME )
#endif
allocateDebugInstanceFromRequirements
:: forall m es
. (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)
=> [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo es
-> m Instance
allocateDebugInstanceFromRequirements :: forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
allocateDebugInstanceFromRequirements [InstanceRequirement]
required [InstanceRequirement]
optional InstanceCreateInfo es
baseCreateInfo = do
let
debugMessengerCreateInfo :: DebugUtilsMessengerCreateInfoEXT
debugMessengerCreateInfo =
DebugUtilsMessengerCreateInfoEXT
forall a. Zero a => a
zero
{ messageSeverity =
DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT
.|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT
, messageType =
DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT
.|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT
.|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT
, pfnUserCallback = debugCallbackPtr
}
validationFeatures :: ValidationFeaturesEXT
validationFeatures =
Vector ValidationFeatureEnableEXT
-> Vector ValidationFeatureDisableEXT -> ValidationFeaturesEXT
ValidationFeaturesEXT [Item (Vector ValidationFeatureEnableEXT)
ValidationFeatureEnableEXT
VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] []
instanceCreateInfo
:: InstanceCreateInfo
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo :: InstanceCreateInfo
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo =
InstanceCreateInfo es
baseCreateInfo
{ Instance.next =
debugMessengerCreateInfo
:& validationFeatures
:& Instance.next baseCreateInfo
}
additionalRequirements :: l
additionalRequirements =
[ RequireInstanceExtension
{ instanceExtensionLayerName :: Maybe ByteString
instanceExtensionLayerName = Maybe ByteString
forall a. Maybe a
Nothing
, instanceExtensionName :: ByteString
instanceExtensionName = ByteString
forall a. (Eq a, IsString a) => a
EXT_DEBUG_UTILS_EXTENSION_NAME
, instanceExtensionMinVersion :: Word32
instanceExtensionMinVersion = Word32
forall a. Bounded a => a
minBound
}
]
additionalOptionalRequirements :: l
additionalOptionalRequirements =
[ RequireInstanceLayer
{ instanceLayerName :: ByteString
instanceLayerName = ByteString
"VK_LAYER_KHRONOS_validation"
, instanceLayerMinVersion :: Word32
instanceLayerMinVersion = Word32
forall a. Bounded a => a
minBound
}
, RequireInstanceExtension
{ instanceExtensionLayerName :: Maybe ByteString
instanceExtensionLayerName = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"VK_LAYER_KHRONOS_validation"
, instanceExtensionName :: ByteString
instanceExtensionName = ByteString
forall a. (Eq a, IsString a) => a
EXT_VALIDATION_FEATURES_EXTENSION_NAME
, instanceExtensionMinVersion :: Word32
instanceExtensionMinVersion = Word32
forall a. Bounded a => a
minBound
}
]
inst <-
[InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
-> m Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
allocateInstanceFromRequirements
([InstanceRequirement]
forall {l}. (Item l ~ InstanceRequirement, IsList l) => l
additionalRequirements [InstanceRequirement]
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. Semigroup a => a -> a -> a
<> [InstanceRequirement] -> [InstanceRequirement]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [InstanceRequirement]
required)
([InstanceRequirement]
forall {l}. (Item l ~ InstanceRequirement, IsList l) => l
additionalOptionalRequirements [InstanceRequirement]
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. Semigroup a => a -> a -> a
<> [InstanceRequirement] -> [InstanceRequirement]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [InstanceRequirement]
optional)
InstanceCreateInfo
(DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)
instanceCreateInfo
_ <- withDebugUtilsMessengerEXT inst debugMessengerCreateInfo Nothing allocate
pure inst
allocateInstanceFromRequirements
:: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)
=> [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo es
-> m Instance
allocateInstanceFromRequirements :: forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
allocateInstanceFromRequirements [InstanceRequirement]
required [InstanceRequirement]
optional InstanceCreateInfo es
baseCreateInfo = do
(mbICI, rrs, ors) <-
[InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo es
-> m (Maybe (InstanceCreateInfo es), [RequirementResult],
[RequirementResult])
forall (m :: * -> *) (o :: * -> *) (r :: * -> *) (es :: [*]).
(MonadIO m, Traversable r, Traversable o) =>
r InstanceRequirement
-> o InstanceRequirement
-> InstanceCreateInfo es
-> m (Maybe (InstanceCreateInfo es), r RequirementResult,
o RequirementResult)
checkInstanceRequirements
[InstanceRequirement]
required
[InstanceRequirement]
optional
InstanceCreateInfo es
baseCreateInfo
traverse_ sayErr (requirementReport rrs ors)
case mbICI of
Maybe (InstanceCreateInfo es)
Nothing -> IO Instance -> m Instance
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Instance -> m Instance) -> IO Instance -> m Instance
forall a b. (a -> b) -> a -> b
$ String -> IO Instance
forall a. String -> IO a
unsatisfiedConstraints String
"Failed to create instance"
Just InstanceCreateInfo es
ici -> (ReleaseKey, Instance) -> Instance
forall a b. (a, b) -> b
snd ((ReleaseKey, Instance) -> Instance)
-> m (ReleaseKey, Instance) -> m Instance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InstanceCreateInfo es
-> Maybe AllocationCallbacks
-> (IO Instance -> (Instance -> IO ()) -> m (ReleaseKey, Instance))
-> m (ReleaseKey, Instance)
forall (a :: [*]) (io :: * -> *) r.
(Extendss InstanceCreateInfo a, PokeChain a, MonadIO io) =>
InstanceCreateInfo a
-> Maybe AllocationCallbacks
-> (io Instance -> (Instance -> io ()) -> r)
-> r
withInstance InstanceCreateInfo es
ici Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO Instance -> (Instance -> IO ()) -> m (ReleaseKey, Instance)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
portabilityRequirements :: [InstanceRequirement]
portabilityFlags :: InstanceCreateFlags
devicePortabilityRequirements :: [DeviceRequirement]
#if defined(darwin_HOST_OS)
portabilityRequirements =
[ RequireInstanceExtension
{ instanceExtensionLayerName = Nothing
, instanceExtensionName = KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME
, instanceExtensionMinVersion = minBound
}
]
portabilityFlags = INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR
devicePortabilityRequirements =
[ RequireDeviceExtension
{ deviceExtensionLayerName = Nothing
, deviceExtensionName = KHR_PORTABILITY_SUBSET_EXTENSION_NAME
, deviceExtensionMinVersion = minBound
}
]
#else
portabilityRequirements :: [InstanceRequirement]
portabilityRequirements = []
portabilityFlags :: InstanceCreateFlags
portabilityFlags = InstanceCreateFlags
forall a. Zero a => a
zero
devicePortabilityRequirements :: [DeviceRequirement]
devicePortabilityRequirements = []
#endif
allocateVulkanInstance
:: (MonadResource m)
=> Vector ByteString
-> Maybe ApplicationInfo
-> [InstanceRequirement]
-> [InstanceRequirement]
-> m Instance
allocateVulkanInstance :: forall (m :: * -> *).
MonadResource m =>
Vector ByteString
-> Maybe ApplicationInfo
-> [InstanceRequirement]
-> [InstanceRequirement]
-> m Instance
allocateVulkanInstance Vector ByteString
exts Maybe ApplicationInfo
appInfo [InstanceRequirement]
reqs [InstanceRequirement]
optReqs =
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo '[] -> m Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
allocateInstanceFromRequirements
([InstanceRequirement]
portabilityRequirements [InstanceRequirement]
-> [InstanceRequirement] -> [InstanceRequirement]
forall a. Semigroup a => a -> a -> a
<> [InstanceRequirement]
reqs)
[InstanceRequirement]
optReqs
InstanceCreateInfo '[]
forall a. Zero a => a
zero
{ applicationInfo = appInfo
, enabledExtensionNames = exts
, flags = portabilityFlags
}
allocateDeviceFromRequirements
:: forall m
. (MonadResource m)
=> [DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
allocateDeviceFromRequirements :: forall (m :: * -> *).
MonadResource m =>
[DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
allocateDeviceFromRequirements [DeviceRequirement]
required [DeviceRequirement]
optional PhysicalDevice
phys DeviceCreateInfo '[]
baseCreateInfo = do
(mbDCI, rrs, ors) <-
[DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m (Maybe (SomeStruct DeviceCreateInfo), [RequirementResult],
[RequirementResult])
forall (m :: * -> *) (o :: * -> *) (r :: * -> *).
(MonadIO m, Traversable r, Traversable o) =>
r DeviceRequirement
-> o DeviceRequirement
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m (Maybe (SomeStruct DeviceCreateInfo), r RequirementResult,
o RequirementResult)
checkDeviceRequirements
([DeviceRequirement]
devicePortabilityRequirements [DeviceRequirement] -> [DeviceRequirement] -> [DeviceRequirement]
forall a. Semigroup a => a -> a -> a
<> [DeviceRequirement]
required)
[DeviceRequirement]
optional
PhysicalDevice
phys
DeviceCreateInfo '[]
baseCreateInfo
traverse_ sayErr (requirementReport rrs ors)
case mbDCI of
Maybe (SomeStruct DeviceCreateInfo)
Nothing -> IO Device -> m Device
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Device -> m Device) -> IO Device -> m Device
forall a b. (a -> b) -> a -> b
$ String -> IO Device
forall a. String -> IO a
unsatisfiedConstraints String
"Failed to create instance"
Just (SomeStruct DeviceCreateInfo es
dci) -> (ReleaseKey, Device) -> Device
forall a b. (a, b) -> b
snd ((ReleaseKey, Device) -> Device)
-> m (ReleaseKey, Device) -> m Device
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PhysicalDevice
-> DeviceCreateInfo es
-> Maybe AllocationCallbacks
-> (IO Device -> (Device -> IO ()) -> m (ReleaseKey, Device))
-> m (ReleaseKey, Device)
forall (a :: [*]) (io :: * -> *) r.
(Extendss DeviceCreateInfo a, PokeChain a, MonadIO io) =>
PhysicalDevice
-> DeviceCreateInfo a
-> Maybe AllocationCallbacks
-> (io Device -> (Device -> io ()) -> r)
-> r
withDevice PhysicalDevice
phys DeviceCreateInfo es
dci Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO Device -> (Device -> IO ()) -> m (ReleaseKey, Device)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
pickPhysicalDevice
:: (MonadIO m, Ord b)
=> Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (Maybe (a, PhysicalDevice))
pickPhysicalDevice :: forall (m :: * -> *) b a.
(MonadIO m, Ord b) =>
Instance
-> (PhysicalDevice -> m (Maybe a))
-> (a -> b)
-> m (Maybe (a, PhysicalDevice))
pickPhysicalDevice Instance
inst PhysicalDevice -> m (Maybe a)
devInfo a -> b
score = do
(_, devs) <- Instance -> m (Result, "physicalDevices" ::: Vector PhysicalDevice)
forall (io :: * -> *).
MonadIO io =>
Instance
-> io (Result, "physicalDevices" ::: Vector PhysicalDevice)
enumeratePhysicalDevices Instance
inst
infos <-
catMaybes
<$> sequence
[ do
isCPU <-
(PHYSICAL_DEVICE_TYPE_CPU ==) . deviceType
<$> getPhysicalDeviceProperties d
if isCPU then pure Nothing else fmap (,d) <$> devInfo d
| d <- toList devs
]
pure $ maximumBy_ (comparing (score . fst)) infos
physicalDeviceName :: (MonadIO m) => PhysicalDevice -> m Text
physicalDeviceName :: forall (m :: * -> *). MonadIO m => PhysicalDevice -> m Text
physicalDeviceName =
(PhysicalDeviceProperties -> Text)
-> m PhysicalDeviceProperties -> m Text
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (PhysicalDeviceProperties -> ByteString)
-> PhysicalDeviceProperties
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhysicalDeviceProperties -> ByteString
deviceName) (m PhysicalDeviceProperties -> m Text)
-> (PhysicalDevice -> m PhysicalDeviceProperties)
-> PhysicalDevice
-> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhysicalDevice -> m PhysicalDeviceProperties
forall (io :: * -> *).
MonadIO io =>
PhysicalDevice -> io PhysicalDeviceProperties
getPhysicalDeviceProperties
maximumBy_ :: (Foldable t) => (a -> a -> Ordering) -> t a -> Maybe a
maximumBy_ :: forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> Maybe a
maximumBy_ a -> a -> Ordering
f t a
xs = if t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just ((a -> a -> Ordering) -> t a -> a
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy a -> a -> Ordering
f t a
xs)
{-# DEPRECATED createInstanceFromRequirements "Renamed to allocateInstanceFromRequirements" #-}
createInstanceFromRequirements
:: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)
=> [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo es
-> m Instance
createInstanceFromRequirements :: forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createInstanceFromRequirements = [InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
allocateInstanceFromRequirements
{-# DEPRECATED createDebugInstanceFromRequirements "Renamed to allocateDebugInstanceFromRequirements" #-}
createDebugInstanceFromRequirements
:: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)
=> [InstanceRequirement]
-> [InstanceRequirement]
-> InstanceCreateInfo es
-> m Instance
createDebugInstanceFromRequirements :: forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
createDebugInstanceFromRequirements = [InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
forall (m :: * -> *) (es :: [*]).
(MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) =>
[InstanceRequirement]
-> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance
allocateDebugInstanceFromRequirements
{-# DEPRECATED createDeviceFromRequirements "Renamed to allocateDeviceFromRequirements" #-}
createDeviceFromRequirements
:: (MonadResource m)
=> [DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
createDeviceFromRequirements :: forall (m :: * -> *).
MonadResource m =>
[DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
createDeviceFromRequirements = [DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
forall (m :: * -> *).
MonadResource m =>
[DeviceRequirement]
-> [DeviceRequirement]
-> PhysicalDevice
-> DeviceCreateInfo '[]
-> m Device
allocateDeviceFromRequirements