keid-core 0.1.9.0 → 0.1.9.1
raw patch · 8 files changed
+415/−62 lines, 8 filesdep +spirv-enumdep ~basedep ~spirv-reflect-ffidep ~spirv-reflect-types
Dependencies added: spirv-enum
Dependency ranges changed: base, spirv-reflect-ffi, spirv-reflect-types
Files
- ChangeLog.md +9/−0
- keid-core.cabal +6/−5
- src/Engine/App.hs +56/−3
- src/Engine/Run.hs +3/−3
- src/Engine/Setup.hs +68/−12
- src/Engine/SpirV/Reflect.hs +19/−17
- src/Engine/Types.hs +34/−0
- src/Resource/Image.hs +220/−22
ChangeLog.md view
@@ -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`.
keid-core.cabal view
@@ -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
src/Engine/App.hs view
@@ -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
src/Engine/Run.hs view
@@ -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
src/Engine/Setup.hs view
@@ -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
src/Engine/SpirV/Reflect.hs view
@@ -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 ) )
src/Engine/Types.hs view
@@ -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
src/Resource/Image.hs view
@@ -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