{-# LANGUAGE CPP #-} module Engine.Setup where import RIO import UnliftIO.Resource (MonadResource) import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk import Vulkan.Extensions.VK_EXT_debug_utils qualified as Ext import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 qualified as Khr import Vulkan.Extensions.VK_KHR_surface qualified as Khr import Vulkan.Requirement (InstanceRequirement(..)) import Vulkan.Utils.Initialization (createInstanceFromRequirements) import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA #if MIN_VERSION_vulkan(3,15,0) import Foreign.Ptr (castFunPtr) import Vulkan.Dynamic qualified as VkDynamic #endif import Engine.Setup.Device (allocatePhysical, allocateLogical) import Engine.Setup.Window qualified as Window import Engine.Types (GlobalHandles(..)) import Engine.Types.Options (Options(..)) import Engine.Vulkan.Swapchain (SwapchainResources) import Engine.Vulkan.Types (PhysicalDeviceInfo(..)) import Engine.Vulkan.Types qualified as Vulkan import Engine.Worker qualified as Worker import Engine.StageSwitch (newStageSwitchVar) setup :: ( HasLogFunc env , MonadResource (RIO env) ) => Options -> RIO env (GlobalHandles, Maybe SwapchainResources) setup :: forall env. (HasLogFunc env, MonadResource (RIO env)) => Options -> RIO env (GlobalHandles, Maybe SwapchainResources) setup Options ghOptions = do forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> Utf8Builder displayShow Options ghOptions ([InstanceRequirement] windowReqs, Window ghWindow) <- forall (m :: * -> *) env. (MonadUnliftIO m, MonadReader env m, HasLogFunc env, MonadResource m) => Bool -> Maybe (Int, Int) -> Natural -> SizePicker -> Text -> m ([InstanceRequirement], Window) Window.allocate (Options -> Bool optionsFullscreen Options ghOptions) (Options -> Maybe (Int, Int) optionsSize Options ghOptions) (Options -> Natural optionsDisplay Options ghOptions) SizePicker Window.pickLargest Text "Keid Engine" forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating instance" Instance ghInstance <- forall (m :: * -> *) (es :: [*]). (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) => [InstanceRequirement] -> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance createInstanceFromRequirements (InstanceRequirement deviceProps forall a. a -> [a] -> [a] : InstanceRequirement debugUtils forall a. a -> [a] -> [a] : [InstanceRequirement] windowReqs) forall a. Monoid a => a mempty forall a. Zero a => a zero forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating surface" (ReleaseKey _surfaceKey, SurfaceKHR ghSurface) <- forall (m :: * -> *). MonadResource m => Window -> Instance -> m (ReleaseKey, SurfaceKHR) Window.allocateSurface Window ghWindow Instance ghInstance forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating physical device" (PhysicalDeviceInfo ghPhysicalDeviceInfo, PhysicalDevice ghPhysicalDevice) <- forall (m :: * -> *) env. (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasLogFunc env, MonadResource m) => Instance -> Maybe SurfaceKHR -> (PhysicalDeviceInfo -> Word64) -> m (PhysicalDeviceInfo, PhysicalDevice) allocatePhysical Instance ghInstance (forall a. a -> Maybe a Just SurfaceKHR ghSurface) PhysicalDeviceInfo -> Word64 pdiTotalMemory forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating logical device" Device ghDevice <- forall (m :: * -> *) env. (MonadUnliftIO m, MonadReader env m, HasLogFunc env, MonadResource m) => PhysicalDeviceInfo -> PhysicalDevice -> m Device allocateLogical PhysicalDeviceInfo ghPhysicalDeviceInfo PhysicalDevice ghPhysicalDevice forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating VMA" let allocatorCI :: VMA.AllocatorCreateInfo allocatorCI :: AllocatorCreateInfo allocatorCI = forall a. Zero a => a zero { $sel:physicalDevice:AllocatorCreateInfo :: Ptr PhysicalDevice_T VMA.physicalDevice = PhysicalDevice -> Ptr PhysicalDevice_T Vk.physicalDeviceHandle PhysicalDevice ghPhysicalDevice , $sel:device:AllocatorCreateInfo :: Ptr Device_T VMA.device = Device -> Ptr Device_T Vk.deviceHandle Device ghDevice , $sel:instance':AllocatorCreateInfo :: Ptr Instance_T VMA.instance' = Instance -> Ptr Instance_T Vk.instanceHandle Instance ghInstance , $sel:vulkanFunctions:AllocatorCreateInfo :: Maybe VulkanFunctions VMA.vulkanFunctions = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Device -> Instance -> VulkanFunctions vmaVulkanFunctions Device ghDevice Instance ghInstance } (ReleaseKey _vmaKey, Allocator ghAllocator) <- forall (io :: * -> *) r. MonadIO io => AllocatorCreateInfo -> (io Allocator -> (Allocator -> io ()) -> r) -> r VMA.withAllocator AllocatorCreateInfo allocatorCI forall (m :: * -> *) a. MonadResource m => IO a -> (a -> IO ()) -> m (ReleaseKey, a) Resource.allocate 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 "Releasing VMA") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey Resource.register Queues (QueueFamilyIndex, Queue) ghQueues <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ PhysicalDeviceInfo -> Device -> IO (Queues (QueueFamilyIndex, Queue)) pdiGetQueues PhysicalDeviceInfo ghPhysicalDeviceInfo Device ghDevice forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug forall a b. (a -> b) -> a -> b $ Utf8Builder "Got command queues: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Utf8Builder displayShow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (QueueFamilyIndex -> Word32 unQueueFamilyIndex forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) Queues (QueueFamilyIndex, Queue) ghQueues) Extent2D screen <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ Window -> IO Extent2D Window.getExtent2D Window ghWindow Var Extent2D ghScreenVar <- forall (m :: * -> *) a. MonadUnliftIO m => a -> m (Var a) Worker.newVar Extent2D screen StageSwitchVar ghStageSwitch <- forall (m :: * -> *). MonadIO m => m StageSwitchVar newStageSwitchVar pure (GlobalHandles{Var Extent2D StageSwitchVar Window Device Instance PhysicalDevice SurfaceKHR Allocator PhysicalDeviceInfo Queues (QueueFamilyIndex, Queue) Options $sel:ghStageSwitch:GlobalHandles :: StageSwitchVar $sel:ghScreenVar:GlobalHandles :: Var Extent2D $sel:ghQueues:GlobalHandles :: Queues (QueueFamilyIndex, Queue) $sel:ghAllocator:GlobalHandles :: Allocator $sel:ghDevice:GlobalHandles :: Device $sel:ghPhysicalDeviceInfo:GlobalHandles :: PhysicalDeviceInfo $sel:ghPhysicalDevice:GlobalHandles :: PhysicalDevice $sel:ghInstance:GlobalHandles :: Instance $sel:ghSurface:GlobalHandles :: SurfaceKHR $sel:ghWindow:GlobalHandles :: Window $sel:ghOptions:GlobalHandles :: Options ghStageSwitch :: StageSwitchVar ghScreenVar :: Var Extent2D ghQueues :: Queues (QueueFamilyIndex, Queue) ghAllocator :: Allocator ghDevice :: Device ghPhysicalDevice :: PhysicalDevice ghPhysicalDeviceInfo :: PhysicalDeviceInfo ghSurface :: SurfaceKHR ghInstance :: Instance ghWindow :: Window ghOptions :: Options ..}, forall a. Maybe a Nothing) vmaVulkanFunctions :: Vk.Device -> Vk.Instance -> VMA.VulkanFunctions #if MIN_VERSION_vulkan(3,15,0) vmaVulkanFunctions :: Device -> Instance -> VulkanFunctions vmaVulkanFunctions Vk.Device{DeviceCmds $sel:deviceCmds:Device :: Device -> DeviceCmds deviceCmds :: DeviceCmds deviceCmds} Vk.Instance{InstanceCmds $sel:instanceCmds:Instance :: Instance -> InstanceCmds instanceCmds :: InstanceCmds instanceCmds} = forall a. Zero a => a zero { $sel:vkGetInstanceProcAddr:VulkanFunctions :: PFN_vkGetInstanceProcAddr VMA.vkGetInstanceProcAddr = forall a b. FunPtr a -> FunPtr b castFunPtr forall a b. (a -> b) -> a -> b $ InstanceCmds -> FunPtr (Ptr Instance_T -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction) VkDynamic.pVkGetInstanceProcAddr InstanceCmds instanceCmds , $sel:vkGetDeviceProcAddr:VulkanFunctions :: PFN_vkGetDeviceProcAddr VMA.vkGetDeviceProcAddr = forall a b. FunPtr a -> FunPtr b castFunPtr forall a b. (a -> b) -> a -> b $ DeviceCmds -> FunPtr (Ptr Device_T -> ("pName" ::: Ptr CChar) -> IO PFN_vkVoidFunction) VkDynamic.pVkGetDeviceProcAddr DeviceCmds deviceCmds } #else vmaVulkanFunctions _device _instance = zero #endif setupHeadless :: ( HasLogFunc env , MonadResource (RIO env) ) => Options -> RIO env Headless setupHeadless :: forall env. (HasLogFunc env, MonadResource (RIO env)) => Options -> RIO env Headless setupHeadless Options opts = do forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> Utf8Builder displayShow Options opts forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating instance" Instance hInstance <- forall (m :: * -> *) (es :: [*]). (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es) => [InstanceRequirement] -> [InstanceRequirement] -> InstanceCreateInfo es -> m Instance createInstanceFromRequirements (InstanceRequirement deviceProps forall a. a -> [a] -> [a] : InstanceRequirement debugUtils forall a. a -> [a] -> [a] : [InstanceRequirement] headlessReqs) forall a. Monoid a => a mempty forall a. Zero a => a zero forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating physical device" (PhysicalDeviceInfo hPhysicalDeviceInfo, PhysicalDevice hPhysicalDevice) <- forall (m :: * -> *) env. (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasLogFunc env, MonadResource m) => Instance -> Maybe SurfaceKHR -> (PhysicalDeviceInfo -> Word64) -> m (PhysicalDeviceInfo, PhysicalDevice) allocatePhysical Instance hInstance forall a. Maybe a Nothing PhysicalDeviceInfo -> Word64 pdiTotalMemory forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating logical device" Device hDevice <- forall (m :: * -> *) env. (MonadUnliftIO m, MonadReader env m, HasLogFunc env, MonadResource m) => PhysicalDeviceInfo -> PhysicalDevice -> m Device allocateLogical PhysicalDeviceInfo hPhysicalDeviceInfo PhysicalDevice hPhysicalDevice forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug Utf8Builder "Creating VMA" let allocatorCI :: VMA.AllocatorCreateInfo allocatorCI :: AllocatorCreateInfo allocatorCI = forall a. Zero a => a zero { $sel:physicalDevice:AllocatorCreateInfo :: Ptr PhysicalDevice_T VMA.physicalDevice = PhysicalDevice -> Ptr PhysicalDevice_T Vk.physicalDeviceHandle PhysicalDevice hPhysicalDevice , $sel:device:AllocatorCreateInfo :: Ptr Device_T VMA.device = Device -> Ptr Device_T Vk.deviceHandle Device hDevice , $sel:instance':AllocatorCreateInfo :: Ptr Instance_T VMA.instance' = Instance -> Ptr Instance_T Vk.instanceHandle Instance hInstance , $sel:vulkanFunctions:AllocatorCreateInfo :: Maybe VulkanFunctions VMA.vulkanFunctions = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Device -> Instance -> VulkanFunctions vmaVulkanFunctions Device hDevice Instance hInstance } (ReleaseKey _vmaKey, Allocator hAllocator) <- forall (io :: * -> *) r. MonadIO io => AllocatorCreateInfo -> (io Allocator -> (Allocator -> io ()) -> r) -> r VMA.withAllocator AllocatorCreateInfo allocatorCI forall (m :: * -> *) a. MonadResource m => IO a -> (a -> IO ()) -> m (ReleaseKey, a) Resource.allocate 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 "Releasing VMA") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey Resource.register Queues (QueueFamilyIndex, Queue) hQueues <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ PhysicalDeviceInfo -> Device -> IO (Queues (QueueFamilyIndex, Queue)) pdiGetQueues PhysicalDeviceInfo hPhysicalDeviceInfo Device hDevice forall (m :: * -> *) env. (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) => Utf8Builder -> m () logDebug forall a b. (a -> b) -> a -> b $ Utf8Builder "Got command queues: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> Utf8Builder displayShow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (QueueFamilyIndex -> Word32 unQueueFamilyIndex forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) Queues (QueueFamilyIndex, Queue) hQueues) pure Headless{Device Instance PhysicalDevice Allocator PhysicalDeviceInfo Queues (QueueFamilyIndex, Queue) $sel:hQueues:Headless :: Queues (QueueFamilyIndex, Queue) $sel:hAllocator:Headless :: Allocator $sel:hDevice:Headless :: Device $sel:hPhysicalDevice:Headless :: PhysicalDevice $sel:hPhysicalDeviceInfo:Headless :: PhysicalDeviceInfo $sel:hInstance:Headless :: Instance hQueues :: Queues (QueueFamilyIndex, Queue) hAllocator :: Allocator hDevice :: Device hPhysicalDevice :: PhysicalDevice hPhysicalDeviceInfo :: PhysicalDeviceInfo hInstance :: Instance ..} data Headless = Headless { Headless -> Instance hInstance :: Vk.Instance , Headless -> PhysicalDeviceInfo hPhysicalDeviceInfo :: Vulkan.PhysicalDeviceInfo , Headless -> PhysicalDevice hPhysicalDevice :: Vk.PhysicalDevice , Headless -> Device hDevice :: Vk.Device , Headless -> Allocator hAllocator :: VMA.Allocator , Headless -> Queues (QueueFamilyIndex, Queue) hQueues :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue) } instance Vulkan.HasVulkan Headless where getInstance :: Headless -> Instance getInstance = Headless -> Instance hInstance getQueues :: Headless -> Queues (QueueFamilyIndex, Queue) getQueues = Headless -> Queues (QueueFamilyIndex, Queue) hQueues getPhysicalDevice :: Headless -> PhysicalDevice getPhysicalDevice = Headless -> PhysicalDevice hPhysicalDevice getPhysicalDeviceInfo :: Headless -> PhysicalDeviceInfo getPhysicalDeviceInfo = Headless -> PhysicalDeviceInfo hPhysicalDeviceInfo getDevice :: Headless -> Device getDevice = Headless -> Device hDevice getAllocator :: Headless -> Allocator getAllocator = Headless -> Allocator hAllocator deviceProps :: InstanceRequirement deviceProps :: InstanceRequirement deviceProps = Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement RequireInstanceExtension forall a. Maybe a Nothing forall a. (Eq a, IsString a) => a Khr.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME forall a. Bounded a => a minBound debugUtils :: InstanceRequirement debugUtils :: InstanceRequirement debugUtils = Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement RequireInstanceExtension forall a. Maybe a Nothing forall a. (Eq a, IsString a) => a Ext.EXT_DEBUG_UTILS_EXTENSION_NAME forall a. Bounded a => a minBound headlessReqs :: [InstanceRequirement] headlessReqs :: [InstanceRequirement] headlessReqs = [ Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement RequireInstanceExtension forall a. Maybe a Nothing forall a. (Eq a, IsString a) => a Khr.KHR_SURFACE_EXTENSION_NAME forall a. Bounded a => a minBound ]