diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Changelog for keid-core +## TBA + +- Addded new wrappers to `Engine.App`` + * `withDataDir` to change directory so the `data` directory will match `./data`. + * `withDefaultArgs` to set default options like msaa. +- Added screen-grabbing functions to `Resource.Image`. +- Added compatibility extension for instance CI to run on MoltenVK. +- Added `Engine.Types.HasMonoTime` class and `secondsSinceStart` to get stable monotonic time in a sane range. + ## 0.1.9.0 - Extracted `Engine.UI.Layout` and `...Layout.Linear` to `geomancy-layout`. diff --git a/keid-core.cabal b/keid-core.cabal --- a/keid-core.cabal +++ b/keid-core.cabal @@ -1,17 +1,17 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: keid-core -version: 0.1.9.0 +version: 0.1.9.1 synopsis: Core parts of Keid engine. category: Game Engine homepage: https://keid.haskell-game.dev author: IC Rainbow maintainer: keid@aenor.ru -copyright: 2023 IC Rainbow +copyright: 2024 IC Rainbow license: BSD3 license-file: LICENSE build-type: Simple @@ -148,8 +148,9 @@ , rio >=0.1.12.0 , rio-app , serialise - , spirv-reflect-ffi >=0.2 - , spirv-reflect-types >=0.2 + , spirv-enum ==0.1.* + , spirv-reflect-ffi ==0.3.* + , spirv-reflect-types ==0.3.* , tagged , template-haskell , text diff --git a/src/Engine/App.hs b/src/Engine/App.hs --- a/src/Engine/App.hs +++ b/src/Engine/App.hs @@ -1,16 +1,23 @@ module Engine.App ( engineMain , engineMainWith + , withDataDir + , withDefaultArgs ) where -import RIO +import RIO hiding (traceM) -import RIO.App (appMain) +import Debug.Trace (traceM) import Engine.Run (runStack) import Engine.Setup (setup) +import Engine.Stage.Bootstrap.Setup qualified as Bootstrap import Engine.Types qualified as Engine import Engine.Types.Options (Options(..), getOptions) -import Engine.Stage.Bootstrap.Setup qualified as Bootstrap +import RIO.App (appMain) +import RIO.Directory (doesDirectoryExist, getCurrentDirectory, withCurrentDirectory) +import RIO.FilePath (takeDirectory, takeFileName, ()) +import RIO.List (find, isPrefixOf) +import System.Environment (getArgs, getExecutablePath, withArgs) engineMain :: Engine.StackStage -> IO () engineMain initialStage = engineMainWith (\() -> initialStage) (pure ()) @@ -21,3 +28,49 @@ [ -- XXX: run swapchain bootstrap and replace with next stage Bootstrap.stackStage handoff action ] + +withDataDir :: IO FilePath -> FilePath -> IO a -> IO a +withDataDir getDataDir name action = do + currentDir <- getCurrentDirectory + + executableDir <- fmap takeDirectory getExecutablePath + let shareDir = takeDirectory executableDir "share" + + usrShareName <- fmap takeFileName getDataDir + let + withVer = usrShareName + sansVer = stripVersion withVer + + let + candidates = + [ currentDir + , shareDir withVer + , shareDir sansVer + ] + exists <- for candidates \dir -> + doesDirectoryExist (dir name) + case filter fst (zip exists candidates) of + (True, found) : _rest -> + withCurrentDirectory found $ + action + _ -> do + traceM "Data directory not found:" + traverse_ traceM candidates + exitFailure + where + stripVersion = reverse . drop 1 . dropWhile (/= '-') . reverse + +withDefaultArgs :: [(String, Maybe String)] -> IO a -> IO a +withDefaultArgs defaults action = do + args <- getArgs + withArgs (injectArgs args defaults) action + +injectArgs :: [String] -> [(String, Maybe String)] -> [String] +injectArgs provided = foldr inject provided + where + inject (name, mvalue) acc = + case find (name `isPrefixOf`) provided of + Just _overriden -> + acc + Nothing -> + name : maybeToList mvalue <> acc diff --git a/src/Engine/Run.hs b/src/Engine/Run.hs --- a/src/Engine/Run.hs +++ b/src/Engine/Run.hs @@ -122,13 +122,13 @@ ) else do logInfo $ "Entering stage loop: " <> display sTitle - startTime <- getMonotonicTime + startTime <- liftIO getMonotonicTimeNSec (finalFrame, stageAction) <- bracket sBeforeLoop sAfterLoop \_stagePrivates -> stageLoop (step stKey stage recycler (optionsMaxFPS ghOptions)) startFrame - endTime <- getMonotonicTime + endTime <- liftIO getMonotonicTimeNSec let frames = Frame.fIndex finalFrame - seconds = endTime - startTime + seconds = fromIntegral (endTime - startTime) / 1e9 :: Double logInfo $ "Stage finished: " <> display sTitle logInfo $ "Running time: " <> display seconds diff --git a/src/Engine/Setup.hs b/src/Engine/Setup.hs --- a/src/Engine/Setup.hs +++ b/src/Engine/Setup.hs @@ -4,18 +4,21 @@ import RIO +import GHC.Clock (getMonotonicTimeNSec) import UnliftIO.Resource (MonadResource) import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk +import Vulkan.Core12 (pattern API_VERSION_1_2) 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_portability_enumeration qualified as Khr import Vulkan.Extensions.VK_KHR_surface qualified as Khr import Vulkan.Requirement (InstanceRequirement(..)) import Vulkan.Utils.Initialization (createInstanceFromRequirements) +import Vulkan.Utils.Requirements (checkInstanceRequirements, requirementReport) import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA -import Vulkan.Core12 (pattern API_VERSION_1_2) #if MIN_VERSION_vulkan(3,15,0) import Foreign.Ptr (castFunPtr) @@ -36,7 +39,8 @@ :: ( HasLogFunc env , MonadResource (RIO env) ) - => Options -> RIO env (GlobalHandles, Maybe SwapchainResources) + => Options + -> RIO env (GlobalHandles, Maybe SwapchainResources) setup ghOptions = do logDebug $ displayShow ghOptions @@ -47,8 +51,9 @@ Window.pickLargest "Keid Engine" - logDebug "Creating instance" let + iReqs = portabilityEnum : deviceProps : debugUtils : windowReqs + oReqs = [] appInfo = Vk.ApplicationInfo { apiVersion = API_VERSION_1_2 , applicationName = Nothing @@ -56,11 +61,32 @@ , engineName = Nothing , engineVersion = 0 } - ghInstance <- createInstanceFromRequirements - (deviceProps : debugUtils : windowReqs) - mempty - (zero { Vk.applicationInfo = Just appInfo }) + instanceCI = zero + { Vk.applicationInfo = Just appInfo + , Vk.flags = Vk.INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR + } + (instanceCI', reqResult, optResult) <- checkInstanceRequirements iReqs oReqs instanceCI + let report = fmap fromString $ requirementReport reqResult optResult + ghInstance <- case instanceCI' of + Nothing -> do + logWarn "Instance check failed" + traverse_ logWarn report + createInstanceFromRequirements iReqs oReqs instanceCI + Just ci -> do + traverse_ logDebug report + createInstanceFromRequirements iReqs oReqs ci + setupWith ghOptions ghWindow ghInstance + +setupWith + :: ( HasLogFunc env + , MonadResource (RIO env) + ) + => Options + -> Window.Window + -> Vk.Instance + -> RIO env (GlobalHandles, Maybe SwapchainResources) +setupWith ghOptions ghWindow ghInstance = do logDebug "Creating surface" (_surfaceKey, ghSurface) <- Window.allocateSurface ghWindow ghInstance @@ -93,6 +119,8 @@ ghStageSwitch <- newStageSwitchVar + ghMonotonicStart <- liftIO getMonotonicTimeNSec + pure (GlobalHandles{..}, Nothing) vmaVulkanFunctions @@ -120,12 +148,32 @@ setupHeadless opts = do logDebug $ displayShow opts - logDebug "Creating instance" - hInstance <- createInstanceFromRequirements - (deviceProps : debugUtils : headlessReqs) - mempty - zero + let + iReqs = portabilityEnum : deviceProps : debugUtils : headlessReqs + oReqs = [] + appInfo = Vk.ApplicationInfo + { apiVersion = API_VERSION_1_2 + , applicationName = Nothing + , applicationVersion = 0 + , engineName = Nothing + , engineVersion = 0 + } + instanceCI = zero + { Vk.applicationInfo = Just appInfo + , Vk.flags = Vk.INSTANCE_CREATE_ENUMERATE_PORTABILITY_BIT_KHR + } + (instanceCI', reqResult, optResult) <- checkInstanceRequirements iReqs oReqs instanceCI + let report = fmap fromString $ requirementReport reqResult optResult + hInstance <- case instanceCI' of + Nothing -> do + logWarn "Instance check failed" + traverse_ logWarn report + createInstanceFromRequirements iReqs oReqs instanceCI + Just ci -> do + traverse_ logDebug report + createInstanceFromRequirements iReqs oReqs ci + logDebug "Creating physical device" (hPhysicalDeviceInfo, hPhysicalDevice) <- allocatePhysical hInstance @@ -169,6 +217,12 @@ getDevice = hDevice getAllocator = hAllocator +portabilityEnum :: InstanceRequirement +portabilityEnum = RequireInstanceExtension + Nothing + Khr.KHR_PORTABILITY_ENUMERATION_EXTENSION_NAME + minBound + deviceProps :: InstanceRequirement deviceProps = RequireInstanceExtension Nothing @@ -188,3 +242,5 @@ Khr.KHR_SURFACE_EXTENSION_NAME minBound ] + +-- deriving instance Show InstanceRequirement diff --git a/src/Engine/SpirV/Reflect.hs b/src/Engine/SpirV/Reflect.hs --- a/src/Engine/SpirV/Reflect.hs +++ b/src/Engine/SpirV/Reflect.hs @@ -6,10 +6,12 @@ import Data.IntMap qualified as IntMap import Data.List qualified as List +import Data.SpirV.Enum qualified as SpirV +import Data.SpirV.Enum.StorageClass qualified as StorageClass import Data.SpirV.Reflect.BlockVariable qualified as BlockVariable import Data.SpirV.Reflect.DescriptorBinding qualified as DescriptorBinding import Data.SpirV.Reflect.DescriptorSet qualified as DescriptorSet -import Data.SpirV.Reflect.Enums qualified as Enums +import Data.SpirV.Reflect.Enums qualified as Reflect import Data.SpirV.Reflect.FFI qualified as Reflect import Data.SpirV.Reflect.InterfaceVariable (InterfaceVariable) import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable @@ -19,8 +21,8 @@ import Data.SpirV.Reflect.TypeDescription qualified as TypeDescription import Data.Tree (Tree(..)) import Engine.Vulkan.Pipeline.Stages (StageInfo(..), withLabels) -import RIO.Text qualified as Text import RIO.ByteString (readFile) +import RIO.Text qualified as Text import Vulkan.Core10.Enums.Format qualified as VkFormat invoke @@ -53,14 +55,14 @@ -- | @uniform Foo { ... } foo;@ type BlockBinding = ( Text - , Enums.DescriptorType + , Reflect.DescriptorType , Maybe (Tree ([Maybe Text], BlockSignature)) ) data BlockSignature = BlockSignature { offset :: Word32 , size :: Word32 - , flags :: Enums.TypeFlags + , flags :: Reflect.TypeFlags , scalar :: Maybe Traits.Scalar } deriving (Eq, Ord, Show) @@ -111,7 +113,7 @@ [ display name , " :: " , maybe (displayShow dt) display $ - Enums.descriptorTypeName @Text dt + Reflect.descriptorTypeName @Text dt , maybe mempty ( \sigs' -> @@ -119,7 +121,7 @@ displayShow . toList $ sigs' <&> \(path, BlockSignature{..}) -> ( Text.intercalate "|" (catMaybes path) - , (size, offset, Enums.typeFlagsNames @Text flags) + , (size, offset, Reflect.typeFlagsNames @Text flags) , scalar ) ) @@ -152,15 +154,15 @@ blockTree ancestors bv = Node (path, here) $ map (blockTree path) there where here = BlockSignature - { offset = BlockVariable.offset bv - , size = BlockVariable.size bv + { offset = bv.offset + , size = bv.size , .. } where (flags, scalar) = case BlockVariable.type_description bv of Nothing -> - (Enums.TYPE_FLAG_UNDEFINED, Nothing) + (Reflect.TYPE_FLAG_UNDEFINED, Nothing) Just td -> ( TypeDescription.type_flags td , do @@ -210,7 +212,7 @@ data InterfaceSignature = InterfaceSignature { format :: VkFormat.Format - , flags :: Enums.TypeFlags + , flags :: Reflect.TypeFlags , matrix :: Maybe Traits.Matrix } deriving (Eq, Ord, Show) @@ -224,22 +226,22 @@ moduleInterfaceBinds :: Module -> (InterfaceBinds, InterfaceBinds) moduleInterfaceBinds refl = - ( interfaceBinds Enums.StorageClassInput (Module.input_variables refl) - , interfaceBinds Enums.StorageClassOutput (Module.output_variables refl) + ( interfaceBinds StorageClass.Input (Module.input_variables refl) + , interfaceBinds StorageClass.Output (Module.output_variables refl) ) -interfaceBinds :: Enums.StorageClass -> Vector InterfaceVariable -> InterfaceBinds +interfaceBinds :: SpirV.StorageClass -> Vector InterfaceVariable -> InterfaceBinds interfaceBinds cls vars = IntMap.fromList do var@InterfaceVariable.InterfaceVariable{location} <- toList vars guard $ InterfaceVariable.storage_class var == cls -- XXX: Remove vars like @gl_FragCoord@/@SV_Position@ from potential signatures. - guard $ InterfaceVariable.built_in var == maxBound + guard $ InterfaceVariable.built_in var == Nothing let td = InterfaceVariable.type_description var - Enums.Format format = InterfaceVariable.format var - flags = maybe Enums.TYPE_FLAG_UNDEFINED TypeDescription.type_flags td + Reflect.Format format = InterfaceVariable.format var + flags = maybe Reflect.TYPE_FLAG_UNDEFINED TypeDescription.type_flags td stuff = do TypeDescription.TypeDescription{traits} <- td @@ -258,7 +260,7 @@ pure ( fromIntegral location , ( InterfaceVariable.name var - , Enums.typeFlagsNames @Text flags + , Reflect.typeFlagsNames @Text flags , signature ) ) diff --git a/src/Engine/Types.hs b/src/Engine/Types.hs --- a/src/Engine/Types.hs +++ b/src/Engine/Types.hs @@ -5,6 +5,7 @@ import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as ResourceT import Data.Kind (Type) +import GHC.Clock (getMonotonicTimeNSec) import Graphics.UI.GLFW qualified as GLFW import RIO.App (App, appEnv, appState) import RIO.Lens (_1) @@ -38,6 +39,7 @@ , ghQueues :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue) , ghScreenVar :: Worker.Var Vk.Extent2D , ghStageSwitch :: StageSwitchVar + , ghMonotonicStart :: Word64 } {-# INLINE askScreenVar #-} @@ -53,6 +55,38 @@ getPhysicalDeviceInfo = ghPhysicalDeviceInfo getDevice = ghDevice getAllocator = ghAllocator + +class HasMonotime env where + getMonotonicTimeStart :: env -> Word64 + +instance HasMonotime GlobalHandles where + {-# INLINE getMonotonicTimeStart #-} + getMonotonicTimeStart = ghMonotonicStart + +instance HasMonotime (App GlobalHandles st) where + {-# INLINE getMonotonicTimeStart #-} + getMonotonicTimeStart = ghMonotonicStart . appEnv + +instance HasMonotime (App GlobalHandles st, Frame rp p rr) where + {-# INLINE getMonotonicTimeStart #-} + getMonotonicTimeStart = ghMonotonicStart . appEnv . fst + +{-# INLINE nsSinceStart #-} +nsSinceStart + :: (MonadIO m, MonadReader env m, HasMonotime env) + => m Word64 +nsSinceStart = do + start <- asks getMonotonicTimeStart + now <- liftIO getMonotonicTimeNSec + pure $! now - start + +{-# INLINE secondsSinceStart #-} +secondsSinceStart + :: (MonadIO m, MonadReader env m, HasMonotime env) + => m Float +secondsSinceStart = do + dt <- nsSinceStart + pure $! fromIntegral dt / 1e9 -- * Stage stack diff --git a/src/Resource/Image.hs b/src/Resource/Image.hs --- a/src/Resource/Image.hs +++ b/src/Resource/Image.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-} module Resource.Image @@ -5,11 +6,23 @@ , allocate , allocateView + , allocateWith + , gpuOnly + , gpuToCpu + + , getSubresourceLayout + , getColorLayout0 + , DstImage , allocateDst , copyBufferToDst , updateFromStorable + , DstImageHost(..) + , allocateDstHost + , allocateDstHost_ + , grabImageColor0 + , transitionLayout , copyBufferToImage @@ -20,6 +33,8 @@ import RIO import Data.Bits (shiftR, (.|.)) +import Foreign (Ptr) +import GHC.Records (HasField(..)) import RIO.Vector qualified as Vector import RIO.Vector.Storable qualified as Storable import UnliftIO.Resource (MonadResource) @@ -36,15 +51,40 @@ import Resource.Vulkan.Named qualified as Named data AllocatedImage = AllocatedImage - { aiAllocation :: VMA.Allocation - , aiExtent :: Vk.Extent3D - , aiFormat :: Vk.Format - , aiImage :: Vk.Image - , aiImageView :: Vk.ImageView - , aiImageRange :: Vk.ImageSubresourceRange + { aiAllocation :: VMA.Allocation + , aiAllocationInfo :: VMA.AllocationInfo + , aiExtent :: Vk.Extent3D + , aiFormat :: Vk.Format + , aiImage :: Vk.Image + , aiImageView :: Vk.ImageView + , aiImageRange :: Vk.ImageSubresourceRange } deriving (Show) +instance HasField "mappedData" AllocatedImage (Ptr ()) where + {-# INLINE getField #-} + getField = VMA.mappedData . aiAllocationInfo + +getSubresourceLayout + :: MonadVulkan env io + => AllocatedImage + -> Vk.ImageSubresource + -> io Vk.SubresourceLayout +getSubresourceLayout ai subr = do + device <- asks getDevice + Vk.getImageSubresourceLayout device ai.aiImage subr + +getColorLayout0 + :: MonadVulkan env io + => AllocatedImage + -> io Vk.SubresourceLayout +getColorLayout0 ai = + getSubresourceLayout ai Vk.ImageSubresource + { aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , mipLevel = 0 + , arrayLayer = 0 + } + allocate :: ( MonadVulkan env io , MonadResource io @@ -58,13 +98,29 @@ -> Vk.Format -> Vk.ImageUsageFlags -> io AllocatedImage -allocate mlabel aspect extent mipLevels numLayers samples format usage = do +allocate = allocateWith gpuOnly + +allocateWith + :: ( MonadVulkan env io + , MonadResource io + ) + => VMA.AllocationCreateInfo + -> Maybe Text + -> Vk.ImageAspectFlags + -> "image dimensions" ::: Vk.Extent3D + -> "mip levels" ::: Word32 + -> "stored layers" ::: Word32 + -> Vk.SampleCountFlagBits + -> Vk.Format + -> Vk.ImageUsageFlags + -> io AllocatedImage +allocateWith allocationCI mlabel aspect extent mipLevels numLayers samples format usage = do allocator <- asks getAllocator - (image, allocation, _info) <- VMA.createImage + (image, allocation, info) <- VMA.createImage allocator imageCI - imageAllocationCI + allocationCI void $! Resource.register $ VMA.destroyImage allocator image allocation traverse_ (Named.object image) mlabel @@ -73,12 +129,13 @@ traverse_ (Named.object imageView) $ fmap (<> ":view") mlabel pure AllocatedImage - { aiAllocation = allocation - , aiExtent = extent - , aiFormat = format - , aiImage = image - , aiImageView = imageView - , aiImageRange = subr + { aiAllocation = allocation + , aiAllocationInfo = info + , aiExtent = extent + , aiFormat = format + , aiImage = image + , aiImageView = imageView + , aiImageRange = subr } where imageType = @@ -95,17 +152,18 @@ , Vk.extent = extent , Vk.mipLevels = mipLevels , Vk.arrayLayers = numLayers - , Vk.tiling = Vk.IMAGE_TILING_OPTIMAL + , Vk.tiling = tiling , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED , Vk.usage = usage , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE , Vk.samples = samples } - imageAllocationCI = zero - { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY - , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT - } + tiling = + if allocationCI.usage == VMA.MEMORY_USAGE_GPU_TO_CPU then + Vk.IMAGE_TILING_LINEAR + else + Vk.IMAGE_TILING_OPTIMAL createFlags = case numLayers of @@ -173,7 +231,7 @@ pool (aiImage ai) mipLevels - numLayers -- XXX: arrayLayers is always 0 for now + numLayers format Vk.IMAGE_LAYOUT_UNDEFINED Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL @@ -203,7 +261,7 @@ pool (aiImage ai) levelCount - layerCount -- XXX: arrayLayers is always 0 for now + layerCount (aiFormat ai) Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL @@ -211,6 +269,146 @@ pure ai where Vk.ImageSubresourceRange{layerCount, levelCount} = aiImageRange ai + +newtype DstImageHost = DstImageHost AllocatedImage + +instance HasField "mappedData" DstImageHost (Ptr ()) where + {-# INLINE getField #-} + getField (DstImageHost ai) = VMA.mappedData ai.aiAllocationInfo + +-- | Allocate a flat image to grab GPU data. +allocateDstHost_ + :: ( MonadVulkan env m + , MonadResource m + ) + => Queues Vk.CommandPool + -> Maybe Text + -> "flat image dimensions" ::: Vk.Extent2D + -> Vk.Format + -> m DstImageHost +allocateDstHost_ pools name extent2d = + allocateDstHost pools name (inflateExtent extent2d 1) 1 1 + +-- | Allocate an image to grab GPU data. +allocateDstHost + :: ( MonadVulkan env m + , MonadResource m + ) + => Queues Vk.CommandPool + -> Maybe Text + -> ("image dimensions" ::: Vk.Extent3D) + -> ("mip levels" ::: Word32) + -> ("stored layers" ::: Word32) + -> Vk.Format + -> m DstImageHost +allocateDstHost pool name extent3d mipLevels numLayers format = do + ai <- allocateWith + gpuToCpu + name + Vk.IMAGE_ASPECT_COLOR_BIT + extent3d + mipLevels + numLayers + Vk.SAMPLE_COUNT_1_BIT + format + (Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT) + + transitionLayout + pool + (aiImage ai) + mipLevels + numLayers -- XXX: arrayLayers is always 0 for now + format + Vk.IMAGE_LAYOUT_UNDEFINED + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + + pure $ DstImageHost ai + +grabImageColor0 + :: MonadVulkan env m + => Queues Vk.CommandPool + -> Vk.CommandBuffer + -> Vk.Image + -> DstImageHost + -> m Vk.SubresourceLayout +grabImageColor0 pools cb src (DstImageHost dst) = do + Vk.cmdCopyImage + cb + src + Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL + dst.aiImage + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + [ Vk.ImageCopy + { srcSubresource = + subrLayers + , srcOffset = + Vk.Offset3D 0 0 0 + , dstSubresource = + subrLayers + , dstOffset = + Vk.Offset3D 0 0 0 + , extent = + dst.aiExtent + } + ] + transitionLayout + pools + dst.aiImage + 1 + 1 + dst.aiFormat + Vk.IMAGE_LAYOUT_UNDEFINED + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + + Vk.cmdPipelineBarrier + cb + Vk.PIPELINE_STAGE_TRANSFER_BIT + Vk.PIPELINE_STAGE_HOST_BIT + zero + mempty + mempty + [ SomeStruct zero + { Vk.srcAccessMask = Vk.ACCESS_TRANSFER_WRITE_BIT + , Vk.dstAccessMask = Vk.ACCESS_HOST_READ_BIT + , Vk.oldLayout = Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + , Vk.newLayout = Vk.IMAGE_LAYOUT_GENERAL + , Vk.image = dst.aiImage + , Vk.subresourceRange = subrRange + } + ] + getSubresourceLayout dst subr + where + subr = Vk.ImageSubresource + { aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , mipLevel = 0 + , arrayLayer = 0 + } + subrLayers = Vk.ImageSubresourceLayers + { aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , mipLevel = 0 + , baseArrayLayer = 0 + , layerCount = 1 + } + subrRange = subresource Vk.IMAGE_ASPECT_COLOR_BIT 1 1 + +gpuOnly :: VMA.AllocationCreateInfo +gpuOnly = zero + { VMA.usage = + VMA.MEMORY_USAGE_GPU_ONLY + , VMA.requiredFlags = + Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT + } + +gpuToCpu :: VMA.AllocationCreateInfo +gpuToCpu = zero + { VMA.flags = + VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = + VMA.MEMORY_USAGE_GPU_TO_CPU + , VMA.requiredFlags = + Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT .|. + Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT + } {-# INLINE updateFromStorable #-} updateFromStorable