keid-core 0.1.11.0 → 0.1.11.1
raw patch · 17 files changed
+761/−94 lines, 17 filesdep ~rio
Dependency ranges changed: rio
Files
- ChangeLog.md +16/−0
- keid-core.cabal +4/−3
- src/Engine/Events/CursorPos.hs +0/−1
- src/Engine/Events/MouseButton.hs +0/−1
- src/Engine/Types/Options.hs +2/−1
- src/Engine/Vulkan/Pipeline/External.hs +81/−28
- src/Engine/Vulkan/Pipeline/Graphics.hs +11/−7
- src/Engine/Vulkan/Shader.hs +4/−3
- src/Engine/Vulkan/Types.hs +3/−0
- src/Engine/Worker.hs +159/−5
- src/Render/Pass/Offscreen.hs +48/−2
- src/Resource/Buffer.hs +0/−1
- src/Resource/Image.hs +67/−20
- src/Resource/Image/Downsample.hs +255/−0
- src/Resource/Source.hs +1/−1
- src/Resource/Static.hs +83/−15
- src/Resource/Texture.hs +27/−6
ChangeLog.md view
@@ -1,5 +1,21 @@ # Changelog for keid-core +## 0.1.11.1++- Added `Texture.fromAllocatedImage`+- Added `Resource.Image.Downsample.mipPyramid`+ * Exported `Image.DstImage` constructor.+ * Added `Image.allocateDstMipFor`.+- Added `Worker.merge1M` for the times you absolutely must do some `MonadUnliftIO m` in reaction to the change.+- Added `Resource.Static.collection` to splice the record type and fill it with source paths.+- Added `MonadTrans Bound` instance.+- Added `Worker.merge*` args-flipped variants of `spawnMerge*` with function in the last position.+- Added `External.Params` wrapper for HKD pipeline collection that keeps the value in a Var.+- Added `External.bindGraphics` helper to bind the most recent pipeline version.+- Fixed 'Specialization.packConstData` for Float->Word32 bitcast.+- Added `Offscreen.settingsTexture` and `settingsCubemap` as baselines.+- Added `AllocatedImage.aiName`.+ ## 0.1.11.0 - Fixes and updates to match geomancy-0.3 rewrite.
keid-core.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.1.+-- This file has been generated from package.yaml by hpack version 0.36.1. -- -- see: https://github.com/sol/hpack name: keid-core-version: 0.1.11.0+version: 0.1.11.1 synopsis: Core parts of Keid engine. category: Game Engine homepage: https://keid.haskell-game.dev@@ -79,6 +79,7 @@ Resource.Compressed.Zstd Resource.Image Resource.Image.Atlas+ Resource.Image.Downsample Resource.Mesh.Codec Resource.Mesh.Types Resource.Mesh.Utils@@ -145,7 +146,7 @@ , optparse-applicative , optparse-simple , resourcet- , rio >=0.1.12.0+ , rio >=0.1.24.0 , rio-app , serialise , spirv-enum ==0.1.*
src/Engine/Events/CursorPos.hs view
@@ -2,7 +2,6 @@ import RIO -import Data.Type.Equality (type (~)) import Geomancy (Vec2, vec2, pattern WithVec2) import GHC.Float (double2Float) import UnliftIO.Resource (MonadResource, ReleaseKey)
src/Engine/Events/MouseButton.hs view
@@ -6,7 +6,6 @@ import RIO -import Data.Type.Equality (type (~)) import Geomancy (Vec2) import UnliftIO.Resource (ReleaseKey)
src/Engine/Types/Options.hs view
@@ -9,6 +9,7 @@ import Options.Applicative.Simple qualified as Opt import Vulkan.Core10 qualified as Vk import Vulkan.Extensions.VK_KHR_surface qualified as Khr+import Data.Version (showVersion) import Paths_keid_core qualified @@ -28,7 +29,7 @@ getOptions :: IO Options getOptions = do (options, ()) <- Opt.simpleOptions- $(Opt.simpleVersion Paths_keid_core.version)+ ("Keid Engine " <> showVersion Paths_keid_core.version) header description optionsP
src/Engine/Vulkan/Pipeline/External.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE AllowAmbiguousTypes #-} -- for observeField {-# LANGUAGE UndecidableInstances #-} module Engine.Vulkan.Pipeline.External ( Process , spawn , spawnReflect+ , spawnReflect_ , loadConfig , loadConfigReflect@@ -13,11 +14,13 @@ , newObserverGraphics , observeGraphics+ , bindGraphics , newObserverCompute , observeCompute , type (^)+ , Params , ConfigureGraphics , ConfigureCompute , Observers@@ -31,7 +34,7 @@ import Control.Monad.Trans.Resource (ResourceT) import Data.List (maximum) import Data.Tagged (Tagged(..))-import Data.Type.Equality (type (~))+import GHC.Stack (withFrozenCallStack) import RIO.ByteString qualified as ByteString import RIO.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist) import RIO.FilePath ((</>), (<.>))@@ -45,12 +48,13 @@ import Render.Code (Code(..)) import Engine.SpirV.Reflect qualified as Reflect import Engine.Types (StageFrameRIO, StageRIO)+import Engine.Vulkan.DescSets (Compatible) import Engine.Vulkan.Pipeline.Compute (Compute) import Engine.Vulkan.Pipeline.Compute qualified as Compute import Engine.Vulkan.Pipeline.Graphics qualified as Graphics import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader-import Engine.Vulkan.Types (DsLayoutBindings, HasRenderPass)+import Engine.Vulkan.Types (Bound, DsLayoutBindings, HasRenderPass) import Engine.Worker qualified as Worker type Process config = Worker.Timed () config@@ -111,6 +115,22 @@ -> m (Process config) spawnReflect = spawn loadConfigReflect +{- | The worker that only keeps the loaded data without further processing.++Can be used to share the loaded data.+-}+spawnReflect_+ :: ( MonadResource m+ , MonadUnliftIO m+ , MonadReader env m+ , HasLogFunc env+ , StageInfo stages+ )+ => Text+ -> stages (Maybe FilePath)+ -> m (Process (stages (Maybe ByteString), Reflect.Reflect stages))+spawnReflect_ name stages = spawn loadConfigReflect name stages id+ checkTime :: MonadIO io => UTCTime@@ -195,12 +215,13 @@ type Observer pipeline = Worker.ObserverIO (ReleaseKey, pipeline) newObserverGraphics- :: ( pipeline ~ Graphics.Pipeline dsl vertices instances- , Worker.HasOutput worker- , Shader.Specialization (Graphics.Specialization pipeline)- , HasRenderPass renderpass- , Worker.GetOutput worker ~ Graphics.Configure pipeline- )+ :: ( HasCallStack+ , pipeline ~ Graphics.Pipeline dsl vertices instances+ , Worker.HasOutput worker+ , Shader.Specialization (Graphics.Specialization pipeline)+ , HasRenderPass renderpass+ , Worker.GetOutput worker ~ Graphics.Configure pipeline+ ) => renderpass -> Vk.SampleCountFlagBits -> worker@@ -208,11 +229,13 @@ newObserverGraphics rp msaa process = do initialConfig <- Worker.getOutputData process - initial <- Graphics.allocate- Nothing- msaa- initialConfig- rp+ initial <-+ withFrozenCallStack $+ Graphics.allocate+ Nothing+ msaa+ initialConfig+ rp Worker.newObserverIO initial @@ -223,6 +246,7 @@ , pipeline ~ Graphics.Pipeline dsl vertices instances , spec ~ Graphics.Specialization pipeline , Shader.Specialization spec+ , HasCallStack ) => renderpass -> Vk.SampleCountFlagBits@@ -231,28 +255,48 @@ -> Worker.ObserverIO (ReleaseKey, pipeline) -> StageFrameRIO rp p fr rs () observeGraphics rp msaa sceneBinds configP output =- void $! Worker.observeIO configP output \(oldKey, _old) config -> do- logDebug "Rebuilding pipeline"- Resource.release oldKey- mapRIO fst $ Graphics.allocate- Nothing- msaa- ( config- { Graphics.cDescLayouts = sceneBinds- }- )- rp+ withFrozenCallStack $ void $!+ Worker.observeIO configP output \(oldKey, _old) config -> do+ logDebug "Rebuilding pipeline"+ Resource.release oldKey+ mapRIO fst $ Graphics.allocate+ Nothing+ msaa+ ( config+ { Graphics.cDescLayouts = sceneBinds+ }+ )+ rp +{-# INLINE bindGraphics #-}+bindGraphics+ :: forall+ pipeline m+ pipeLayout vertices instances+ boundLayout oldVertices oldInstances+ . ( pipeline ~ Graphics.Pipeline pipeLayout vertices instances+ , MonadUnliftIO m+ , Compatible pipeLayout boundLayout+ )+ => Vk.CommandBuffer+ -> Worker.ObserverIO (ReleaseKey, pipeline)+ -> Bound boundLayout vertices instances m ()+ -> Bound boundLayout oldVertices oldInstances m ()+bindGraphics cb fr action = do+ (_key, pipeline) <- Worker.readObservedIO fr+ Graphics.bind @pipeline cb pipeline action+ newObserverCompute :: ( config ~ Compute.Configure pipeline () , pipeline ~ Compute.Pipeline dsl Compute Compute+ , HasCallStack ) => Process config -> ResourceT (StageRIO rs) (Observer pipeline) newObserverCompute process = do initialConfig <- Worker.getOutputData process - initial <- Compute.allocate initialConfig+ initial <- withFrozenCallStack $ Compute.allocate initialConfig Worker.newObserverIO initial @@ -280,12 +324,21 @@ data ConfigureGraphics p data ConfigureCompute p data Observers p+data Params p type family f ^ p where+ Identity ^ Params p = p Identity ^ p = p- ConfigureGraphics ^ p = Process (Graphics.Configure p)- ConfigureCompute ^ p = Process (Compute.Configure p ())++ ConfigureGraphics ^ Params p = Worker.Var p+ ConfigureGraphics ^ p = Worker.Var (Graphics.Configure p)++ ConfigureCompute ^ Params p = Worker.Var p+ ConfigureCompute ^ p = Worker.Var (Compute.Configure p ())++ Observers ^ Params p = Worker.ObserverIO p Observers ^ p = Observer p+ f ^ p = f p observeField
src/Engine/Vulkan/Pipeline/Graphics.hs view
@@ -43,7 +43,6 @@ import Data.Kind (Type) import Data.List qualified as List import Data.Tagged (Tagged(..))-import Data.Type.Equality (type (~)) import Data.Vector qualified as Vector import Geomancy (Transform) import GHC.Stack (withFrozenCallStack)@@ -180,9 +179,9 @@ -> Config dsl vertices instances spec -> renderpass -> m (ReleaseKey, pipeline)-allocate extent msaa config renderpass =+allocate extent_ msaa config renderpass = withFrozenCallStack $- Pipeline.allocateWith $ create extent msaa renderpass config+ Pipeline.allocateWith $ create extent_ msaa renderpass config create :: ( MonadVulkan env io@@ -195,7 +194,7 @@ -> renderpass -> Config dsl vertices instances spec -> io (Pipeline dsl vertices instances)-create mextent msaa renderpass Config{..} = withFrozenCallStack do+create extent_ msaa renderpass Config{..} = withFrozenCallStack do -- TODO: get from outside dsLayouts <- Layout.create $ Vector.fromList (unTagged cDescLayouts) @@ -258,7 +257,7 @@ , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN ] - (viewportState, dynamicState) = case mextent of+ (viewportState, dynamicState) = case extent_ of Nothing -> ( zero { Vk.viewportCount = 1@@ -354,11 +353,16 @@ Vk.COLOR_COMPONENT_A_BIT bind- :: ( Compatible pipeLayout boundLayout+ :: forall+ pipeline pipeLayout vertices instances+ boundLayout oldVertices oldInstances+ m+ . ( pipeline ~ Pipeline pipeLayout vertices instances+ , Compatible pipeLayout boundLayout , MonadIO m ) => Vk.CommandBuffer- -> Pipeline pipeLayout vertices instances+ -> pipeline -> Bound boundLayout vertices instances m () -> Bound boundLayout oldVertices oldInstances m () bind cb Pipeline{pipeline} (Bound attrAction) = do
src/Engine/Vulkan/Shader.hs view
@@ -18,11 +18,12 @@ import Data.Vector qualified as Vector import Data.Vector.Storable qualified as Storable import Foreign qualified+import GHC.Float (castFloatToWord32) import GHC.Stack (withFrozenCallStack)-import Vulkan.Core10 qualified as Vk+import Unsafe.Coerce (unsafeCoerce) import Vulkan.CStruct.Extends (SomeStruct(..))+import Vulkan.Core10 qualified as Vk import Vulkan.Zero (Zero(..))-import Unsafe.Coerce (unsafeCoerce) import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Types (MonadVulkan, getDevice)@@ -150,7 +151,7 @@ packConstData = unsafeCoerce instance SpecializationConst Float where- packConstData = unsafeCoerce+ packConstData = castFloatToWord32 instance SpecializationConst Bool where packConstData = bool 0 1
src/Engine/Vulkan/Types.hs view
@@ -123,3 +123,6 @@ deriving stock (Foldable, Traversable, Functor) deriving newtype (Applicative, Monad, MonadIO, MonadUnliftIO) deriving newtype (MonadReader r, MonadState s)++instance MonadTrans (Bound dsl v i) where+ lift = Bound
src/Engine/Worker.hs view
@@ -34,6 +34,13 @@ , spawnTimed_ , Merge(..)+ , merge1+ , mergeNeq1+ , merge1M+ , merge2+ , merge3+ , merge4+ , mergeT , spawnMerge1 , spawnMerge2 , spawnMerge3@@ -384,7 +391,17 @@ => (GetOutput i -> o) -> i -> m (Merge o)-spawnMerge1 f i = do+spawnMerge1 f i = merge1 i f++merge1+ :: ( MonadUnliftIO m+ , MonadResource m+ , HasOutput i+ )+ => i+ -> (GetOutput i -> o)+ -> m (Merge o)+merge1 i f = do output <- atomically do initial <- readTVar (getOutput i) newTVar Versioned@@ -414,6 +431,85 @@ , mOutput = output } +mergeNeq1+ :: ( MonadUnliftIO m+ , MonadResource m+ , HasOutput i+ , Eq o+ )+ => i+ -> (GetOutput i -> o)+ -> m (Merge o)+mergeNeq1 i f = do+ output <- atomically do+ initial <- readTVar (getOutput i)+ newTVar Versioned+ { vVersion = vVersion initial+ , vData = f (vData initial)+ }++ worker <- forkIO $+ forever $ atomically do+ next <- readTVar (getOutput i)+ old <- readTVar output++ let+ nextVersion = next.vVersion+ nextData = f next.vData+ if nextVersion > vVersion old && nextData /= old.vData then+ writeTVar output Versioned+ { vVersion = nextVersion+ , vData = nextData+ }+ else+ retrySTM++ key <- Resource.register $ killThread worker++ pure Merge+ { mWorker = worker+ , mKey = key+ , mOutput = output+ }++merge1M+ :: ( MonadUnliftIO m+ , MonadResource m+ , HasOutput i+ )+ => i+ -> (GetOutput i -> m o)+ -> m (Merge o)+merge1M i p = do+ Versioned{vVersion=vInit, vData=dInit} <- readTVarIO (getOutput i)+ initialOutput <- p dInit+ output <- newTVarIO Versioned+ { vVersion = vInit+ , vData = initialOutput+ }++ worker <- forkIO $+ forever do+ Versioned{vVersion, vData} <-+ atomically do+ next@Versioned{vVersion=vIn} <- readTVar (getOutput i)+ Versioned{vVersion=vOut} <- readTVar output+ if vOut > vIn then retrySTM else pure next+ nextData <- p vData+ atomically $+ writeTVar output Versioned+ { vVersion = vVersion+ , vData = nextData+ }++ key <- Resource.register $ killThread worker++ pure Merge+ { mWorker = worker+ , mKey = key+ , mOutput = output+ }+ spawnMerge2 :: ( MonadUnliftIO m , MonadResource m@@ -424,7 +520,19 @@ -> i1 -> i2 -> m (Merge o)-spawnMerge2 f i1 i2 = do+spawnMerge2 f i1 i2 = merge2 i1 i2 f++merge2+ :: ( MonadUnliftIO m+ , MonadResource m+ , HasOutput i1+ , HasOutput i2+ )+ => i1+ -> i2+ -> (GetOutput i1 -> GetOutput i2 -> o)+ -> m (Merge o)+merge2 i1 i2 f = do output <- atomically do (initial1, initial2) <- (,) <$> readTVar (getOutput i1)@@ -473,7 +581,21 @@ -> i2 -> i3 -> m (Merge o)-spawnMerge3 f i1 i2 i3 = do+spawnMerge3 f i1 i2 i3 = merge3 i1 i2 i3 f++merge3+ :: ( MonadUnliftIO m+ , MonadResource m+ , HasOutput i1+ , HasOutput i2+ , HasOutput i3+ )+ => i1+ -> i2+ -> i3+ -> (GetOutput i1 -> GetOutput i2 -> GetOutput i3 -> o)+ -> m (Merge o)+merge3 i1 i2 i3 f = do output <- atomically do (initial1, initial2, initial3) <- (,,) <$> readTVar (getOutput i1)@@ -526,7 +648,23 @@ -> i3 -> i4 -> m (Merge o)-spawnMerge4 f i1 i2 i3 i4 = do+spawnMerge4 f i1 i2 i3 i4 = merge4 i1 i2 i3 i4 f++merge4+ :: ( MonadUnliftIO m+ , MonadResource m+ , HasOutput i1+ , HasOutput i2+ , HasOutput i3+ , HasOutput i4+ )+ => i1+ -> i2+ -> i3+ -> i4+ -> (GetOutput i1 -> GetOutput i2 -> GetOutput i3 -> GetOutput i4 -> o)+ -> m (Merge o)+merge4 i1 i2 i3 i4 f = do output <- atomically do (initial1, initial2, initial3, initial4) <- (,,,) <$> readTVar (getOutput i1)@@ -581,7 +719,23 @@ => (t (GetOutput input) -> output) -> t input -> m (Merge output)-spawnMergeT f inputs = do+spawnMergeT f inputs = mergeT inputs f++{- |+ Spawn a merge over a homogeneous traversable collection of processes.++ A merging function will receive a collection of outputs to summarize.+-}+mergeT+ :: ( Traversable t+ , HasOutput input+ , MonadUnliftIO m+ , MonadResource m+ )+ => t input+ -> (t (GetOutput input) -> output)+ -> m (Merge output)+mergeT inputs f = do output <- atomically do initial <- traverse (readTVar . getOutput) inputs
src/Render/Pass/Offscreen.hs view
@@ -5,9 +5,11 @@ ( Settings(..) , allocate , Offscreen(..)+ , settingsTexture , colorTexture- , colorCube , depthTexture+ , settingsCubemap+ , colorCube , depthCube ) where @@ -17,9 +19,11 @@ import Control.Monad.Trans.Resource qualified as Resource import Data.Bits ((.|.)) import Data.Vector qualified as Vector+import Geomancy.UVec2 (UVec2, pattern WithUVec2)+import Vulkan.CStruct.Extends (pattern (:&), pattern (::&)) import Vulkan.Core10 qualified as Vk import Vulkan.Core11.Promoted_From_VK_KHR_multiview qualified as Khr-import Vulkan.CStruct.Extends (pattern (:&), pattern (::&))+import Vulkan.NamedType ((:::)) import Vulkan.Utils.Debug qualified as Debug import Vulkan.Zero (zero) @@ -35,6 +39,8 @@ {- XXX: Consider spec wrt. parameters and intended use! https://www.khronos.org/registry/vulkan/specs/1.2-extensions/man/html/vkCmdBlitImage.html++For a depth-only pass consider "Render.ShadowMap.RenderPass". -} data Settings = Settings { sLabel :: Text@@ -49,6 +55,46 @@ , sMipMap :: Bool } deriving (Eq, Show)++{- | Base settings for rendering to textures.++Single-layer, no mips, no multisampling, only the color layer is exported.+-}+settingsTexture+ :: "label" ::: Text+ -> "size" ::: UVec2+ -> "color" ::: Vk.Format+ -> "depth" ::: Vk.Format+ -> Settings+settingsTexture label (WithUVec2 w h) colorFmt depthFmt = Settings+ { sLabel = label+ , sLayers = 1+ , sMultiView = False+ , sSamples = Vk.SAMPLE_COUNT_1_BIT+ , sExtent = Vk.Extent2D w h+ , sFormat = colorFmt+ , sColorLayout = Just Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL+ , sDepthFormat = depthFmt+ , sDepthLayout = Nothing+ , sMipMap = False+ }++{- | Specialize pass for multiview cubemap rendering++6 layers, multiview, mips disabled.+-}+settingsCubemap+ :: "label" ::: Text+ -> "size" ::: UVec2+ -> "color" ::: Vk.Format+ -> "depth" ::: Vk.Format+ -> Settings+settingsCubemap label size colorFmt depthFmt =+ (settingsTexture label size colorFmt depthFmt)+ { sLayers = 6+ , sMultiView = True+ , sMipMap = False -- incompatible with cubes+ } data Offscreen = Offscreen { oRenderPass :: Vk.RenderPass
src/Resource/Buffer.hs view
@@ -3,7 +3,6 @@ import RIO import Data.Bits ((.|.))-import Data.Type.Equality (type (~)) import Data.Vector.Storable qualified as VectorS import Foreign (Storable) import Foreign qualified
src/Resource/Image.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE UndecidableInstances #-} -- HasField l AllocatedImage t => HasField l DstImage t module Resource.Image ( AllocatedImage(..)@@ -13,8 +14,9 @@ , getSubresourceLayout , getColorLayout0 - , DstImage+ , DstImage(..) , allocateDst+ , allocateDstMipFor , copyBufferToDst , updateFromStorable @@ -51,7 +53,8 @@ import Resource.Vulkan.Named qualified as Named data AllocatedImage = AllocatedImage- { aiAllocation :: VMA.Allocation+ { aiName :: Maybe Text+ , aiAllocation :: VMA.Allocation , aiAllocationInfo :: VMA.AllocationInfo , aiExtent :: Vk.Extent3D , aiFormat :: Vk.Format@@ -89,7 +92,7 @@ :: ( MonadVulkan env io , MonadResource io )- => Maybe Text+ => "name" ::: Maybe Text -> Vk.ImageAspectFlags -> "image dimensions" ::: Vk.Extent3D -> "mip levels" ::: Word32@@ -105,7 +108,7 @@ , MonadResource io ) => VMA.AllocationCreateInfo- -> Maybe Text+ -> "name" ::: Maybe Text -> Vk.ImageAspectFlags -> "image dimensions" ::: Vk.Extent3D -> "mip levels" ::: Word32@@ -114,7 +117,7 @@ -> Vk.Format -> Vk.ImageUsageFlags -> io AllocatedImage-allocateWith allocationCI mlabel aspect extent mipLevels numLayers samples format usage = do+allocateWith allocationCI name_ aspect extent mipLevels numLayers samples format usage = do allocator <- asks getAllocator (image, allocation, info) <- VMA.createImage@@ -123,13 +126,14 @@ allocationCI void $! Resource.register $ VMA.destroyImage allocator image allocation- traverse_ (Named.object image) mlabel+ traverse_ (Named.object image) name_ imageView <- allocateView image format subr- traverse_ (Named.object imageView) $ fmap (<> ":view") mlabel+ traverse_ (Named.object imageView) $ fmap (<> ":view") name_ pure AllocatedImage- { aiAllocation = allocation+ { aiName = name_+ , aiAllocation = allocation , aiAllocationInfo = info , aiExtent = extent , aiFormat = format@@ -203,8 +207,14 @@ -------------------------------------------- newtype DstImage = DstImage AllocatedImage+ deriving (Show) --- | Allocate an image and transition it into TRANSFER_DST_OPTIOMAL+instance HasField l AllocatedImage t => HasField l DstImage t where+ {-# INLINE getField #-}+ getField (DstImage ai) = getField @l @AllocatedImage @t ai+++-- | Allocate an image and transition it into TRANSFER_DST_OPTIMAL allocateDst :: ( MonadVulkan env m , MonadResource m@@ -216,7 +226,7 @@ -> ("stored layers" ::: Word32) -> Vk.Format -> m DstImage-allocateDst pool name extent3d mipLevels numLayers format = do+allocateDst pools name extent3d mipLevels numLayers format = do ai <- allocate name Vk.IMAGE_ASPECT_COLOR_BIT@@ -228,7 +238,7 @@ (Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT) transitionLayout- pool+ pools (aiImage ai) mipLevels numLayers@@ -238,6 +248,39 @@ pure $ DstImage ai +{- | Allocate a transfer/blit-capable image using settings from another image.++Aspect, extent, layer count, and format is inherited.++The new image will have the number of mip levels up to the specified.+The mip levels are not initialized and the base layer is not copied.+-}+allocateDstMipFor+ :: (MonadResource m, MonadVulkan env m)+ => Maybe Text+ -> Word32+ -> AllocatedImage+ -> m DstImage+allocateDstMipFor name maxMipLevels src = do+ ai <- allocate+ name+ src.aiImageRange.aspectMask+ src.aiExtent+ dstMipLevels+ src.aiImageRange.layerCount+ Vk.SAMPLE_COUNT_1_BIT+ src.aiFormat+ ( Vk.IMAGE_USAGE_SAMPLED_BIT+ .|. Vk.IMAGE_USAGE_TRANSFER_SRC_BIT+ .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT+ )+ -- XXX: no transition, the mip pyramid will be doing this+ pure $ DstImage ai+ where+ dstMipLevels =+ min maxMipLevels . max 1 . floor @Float . logBase 2 . fromIntegral $+ min src.aiExtent.width src.aiExtent.height+ copyBufferToDst :: ( MonadVulkan env m , Integral deviceSize@@ -272,6 +315,10 @@ newtype DstImageHost = DstImageHost AllocatedImage +instance HasField l AllocatedImage t => HasField l DstImageHost t where+ {-# INLINE getField #-}+ getField (DstImageHost ai) = getField @l @AllocatedImage @t ai+ instance HasField "mappedData" DstImageHost (Ptr ()) where {-# INLINE getField #-} getField (DstImageHost ai) = VMA.mappedData ai.aiAllocationInfo@@ -301,7 +348,7 @@ -> ("stored layers" ::: Word32) -> Vk.Format -> m DstImageHost-allocateDstHost pool name extent3d mipLevels numLayers format = do+allocateDstHost pools name extent3d mipLevels numLayers format = do ai <- allocateWith gpuToCpu name@@ -314,7 +361,7 @@ (Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT) transitionLayout- pool+ pools (aiImage ai) mipLevels numLayers -- XXX: arrayLayers is always 0 for now@@ -470,13 +517,13 @@ -> "old" ::: Vk.ImageLayout -> "new" ::: Vk.ImageLayout -> m ()-transitionLayout pool image mipLevels layerCount format old new = do+transitionLayout pools image mipLevels layerCount format old new = do ctx <- ask case (old, new) of (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) ->- oneshot_ ctx pool qTransfer \buf ->+ oneshot_ ctx pools qTransfer \cmd -> Vk.cmdPipelineBarrier- buf+ cmd Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT Vk.PIPELINE_STAGE_TRANSFER_BIT zero@@ -486,9 +533,9 @@ barrier Vk.IMAGE_ASPECT_COLOR_BIT zero Vk.ACCESS_TRANSFER_WRITE_BIT ) (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL) ->- oneshot_ ctx pool qTransfer \buf ->+ oneshot_ ctx pools qTransfer \cmd -> Vk.cmdPipelineBarrier- buf+ cmd Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT zero@@ -510,9 +557,9 @@ format == Vk.FORMAT_D24_UNORM_S8_UINT (Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL) ->- oneshot_ ctx pool qGraphics \buf ->+ oneshot_ ctx pools qGraphics \cmd -> Vk.cmdPipelineBarrier- buf+ cmd Vk.PIPELINE_STAGE_TRANSFER_BIT Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT zero
+ src/Resource/Image/Downsample.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Resource.Image.Downsample+ ( mipPyramid+ -- * Internals+ ,+ ) where++import RIO++import Data.Bits (shiftR)+import Vulkan.CStruct.Extends (SomeStruct(..))+import Vulkan.Core10 qualified as ImageBlit (ImageBlit(..))+import Vulkan.Core10 qualified as ImageSubresourceRange (ImageSubresourceRange(..))+import Vulkan.Core10 qualified as Vk+import Vulkan.NamedType ((:::))+import Vulkan.Zero (zero)++import Engine.Vulkan.Types (MonadVulkan)+import Resource.Image (AllocatedImage, DstImage(..))+import Resource.Image qualified as Image++-- https://docs.vulkan.org/samples/latest/samples/api/texture_mipmap_generation/README.html+mipPyramid+ :: MonadVulkan env m+ => Vk.CommandBuffer -- XXX: tag to require qGraphics pool+ -> AllocatedImage+ -> Vk.ImageLayout+ -> DstImage+ -> m AllocatedImage+mipPyramid cmd src srcLayout dst = do+ -- dst is undefined everywhere, src is srcLayout+ copyImageBaseToDst cmd src srcLayout dst+ -- src copied and reverted, dst[0] is dst-optimal, the rest are undefined+ transferTransitions cmd dst Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL 0+ -- dst[0] is src-optimal, dst[1+] remain undefined+ for_ @[] [1 .. dst.aiImageRange.levelCount - 1] \toMip -> do+ -- dst[toMip-1] is src-optimal, dst[toMip] is undefined+ transferTransitions cmd dst Vk.IMAGE_LAYOUT_UNDEFINED Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL toMip+ -- dst[toMip] is dst-optimal+ blitMipDown cmd dst (toMip - 1) toMip+ transferTransitions cmd dst Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL toMip+ -- dst[toMip] is src-optimal, will become dst[toMip - 1]+ -- dst[*] are all src-optimal+ finalizeDst cmd dst srcLayout+ -- dst[*] are all srcLayout++{- | Transition src image to src-optimal, copy the data, and transition it back.++The dst image asssumed to be in the dst-optimal layout and not transitioned.+-}+copyImageBaseToDst+ :: MonadIO m+ => Vk.CommandBuffer+ -> "src image" ::: AllocatedImage+ -> "src layout" ::: Vk.ImageLayout+ -> "dst image" ::: DstImage+ -> m ()+copyImageBaseToDst cmd src srcLayout (DstImage dst) = liftIO do+ Vk.cmdPipelineBarrier+ cmd+ Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT+ Vk.PIPELINE_STAGE_TRANSFER_BIT+ zero mempty mempty+ [prepareDst, prepareSrc]++ {-+ VUID-vkCmdCopyImage-srcImageLayout-01917+ srcImageLayout must be VK_IMAGE_LAYOUT_SHARED_PRESENT_KHR, VK_IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL, or VK_IMAGE_LAYOUT_GENERAL+ -}+ Vk.cmdCopyImage+ cmd+ src.aiImage+ Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL+ dst.aiImage+ Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+ [copyBase]++ Vk.cmdPipelineBarrier+ cmd+ Vk.PIPELINE_STAGE_TRANSFER_BIT+ Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT -- hm...+ zero mempty mempty+ [revertSrc]+ where+ prepareDst = SomeStruct zero+ { Vk.srcAccessMask = zero+ , Vk.dstAccessMask = Vk.ACCESS_TRANSFER_WRITE_BIT+ , Vk.oldLayout = Vk.IMAGE_LAYOUT_UNDEFINED+ , Vk.newLayout = Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+ , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.image = dst.aiImage+ , Vk.subresourceRange = dst.aiImageRange+ }++ onlyBaseLevel = src.aiImageRange+ { ImageSubresourceRange.levelCount = 1+ }++ prepareSrc = SomeStruct zero+ { Vk.srcAccessMask = Vk.ACCESS_SHADER_WRITE_BIT+ , Vk.dstAccessMask = Vk.ACCESS_TRANSFER_WRITE_BIT+ , Vk.oldLayout = srcLayout+ , Vk.newLayout = Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL+ , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.image = src.aiImage+ , Vk.subresourceRange = onlyBaseLevel+ }++ copyBase = Vk.ImageCopy+ { srcSubresource = baseISL+ , srcOffset = zero+ , dstSubresource = baseISL+ , dstOffset = zero+ , extent = src.aiExtent+ }+ where+ baseISL = Vk.ImageSubresourceLayers+ { aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT+ , mipLevel = 0+ , baseArrayLayer = 0+ , layerCount = Vk.REMAINING_ARRAY_LAYERS+ }++ revertSrc = SomeStruct zero+ { Vk.srcAccessMask = Vk.ACCESS_TRANSFER_WRITE_BIT+ , Vk.dstAccessMask = Vk.ACCESS_SHADER_READ_BIT+ , Vk.oldLayout = Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL+ , Vk.newLayout = srcLayout+ , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.image = src.aiImage+ , Vk.subresourceRange = onlyBaseLevel+ }++transferTransitions+ :: MonadIO m+ => Vk.CommandBuffer+ -> DstImage+ -> Vk.ImageLayout+ -> Vk.ImageLayout+ -> Word32+ -> m ()+transferTransitions cmd (DstImage image) old new mip =+ Vk.cmdPipelineBarrier cmd srcStage Vk.PIPELINE_STAGE_TRANSFER_BIT zero mempty mempty [barrier]+ where+ barrier = SomeStruct zero+ { Vk.srcAccessMask = srcAccess+ , Vk.dstAccessMask = dstAccess+ , Vk.oldLayout = old+ , Vk.newLayout = new+ , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.image = image.aiImage+ , Vk.subresourceRange = subr+ }+ srcAccess = case old of+ Vk.IMAGE_LAYOUT_UNDEFINED -> zero+ Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL -> Vk.ACCESS_TRANSFER_WRITE_BIT+ Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL -> Vk.ACCESS_TRANSFER_READ_BIT+ _ -> error $ "unexpected old layout: " <> show old+ dstAccess = case new of+ Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL -> Vk.ACCESS_TRANSFER_READ_BIT+ Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL -> Vk.ACCESS_TRANSFER_WRITE_BIT+ _ -> error $ "unexpected new layout: " <> show new+ srcStage = case old of+ Vk.IMAGE_LAYOUT_UNDEFINED -> Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT+ _ -> Vk.PIPELINE_STAGE_TRANSFER_BIT+ subr = Vk.ImageSubresourceRange+ { aspectMask = image.aiImageRange.aspectMask+ , baseMipLevel = mip+ , levelCount = 1+ , baseArrayLayer = 0+ , layerCount = Vk.REMAINING_ARRAY_LAYERS+ }++blitMipDown+ :: MonadIO m+ => Vk.CommandBuffer -- XXX: tag to require qGraphics pool+ -> DstImage+ -> Word32+ -> Word32+ -> m ()+blitMipDown cmd (DstImage image) fromMip toMip =+ Vk.cmdBlitImage+ cmd+ image.aiImage+ Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL+ image.aiImage+ Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+ [region]+ Vk.FILTER_LINEAR+ where+ region = zero+ { ImageBlit.srcSubresource = prevLayers+ , ImageBlit.srcOffsets =+ ( zero+ , Vk.Offset3D+ (max 1 $ fromIntegral image.aiExtent.width `shiftR` fromIntegral fromMip)+ (max 1 $ fromIntegral image.aiExtent.height `shiftR` fromIntegral fromMip)+ 1+ )+ , ImageBlit.dstSubresource = currLayers+ , ImageBlit.dstOffsets =+ ( zero+ , Vk.Offset3D+ (max 1 $ fromIntegral image.aiExtent.width `shiftR` fromIntegral toMip)+ (max 1 $ fromIntegral image.aiExtent.height `shiftR` fromIntegral toMip)+ 1+ )+ }+ where+ prevLayers = Vk.ImageSubresourceLayers+ { aspectMask = image.aiImageRange.aspectMask+ , mipLevel = fromMip+ , baseArrayLayer = 0+ , layerCount = Vk.REMAINING_ARRAY_LAYERS+ }+ currLayers = Vk.ImageSubresourceLayers+ { aspectMask = image.aiImageRange.aspectMask+ , mipLevel = toMip+ , baseArrayLayer = 0+ , layerCount = Vk.REMAINING_ARRAY_LAYERS+ }++finalizeDst+ :: MonadIO m+ => Vk.CommandBuffer+ -> DstImage+ -> Vk.ImageLayout+ -> m AllocatedImage+finalizeDst cmd (DstImage image) toLayout = do+ Vk.cmdPipelineBarrier+ cmd+ Vk.PIPELINE_STAGE_TRANSFER_BIT+ Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT+ zero+ mempty+ mempty+ [barrier]+ pure image+ where+ barrier = SomeStruct zero+ { Vk.srcAccessMask = Vk.ACCESS_TRANSFER_READ_BIT+ , Vk.dstAccessMask = Vk.ACCESS_SHADER_READ_BIT+ , Vk.oldLayout = Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL+ , Vk.newLayout = toLayout+ , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+ , Vk.image = image.aiImage+ , Vk.subresourceRange = image.aiImageRange+ }
src/Resource/Source.hs view
@@ -26,7 +26,7 @@ getField = \case Bytes label _bytes -> label BytesZstd label _bytes -> label- File label _path -> label+ File label path -> label <|> Just (Text.pack path) instance Show Source where show = \case
src/Resource/Static.hs view
@@ -2,17 +2,17 @@ import RIO -import Data.Char (isDigit, isUpper, toUpper)+import Data.Char (isDigit, isLower, isUpper, toUpper) import Language.Haskell.TH (Q, Dec)+import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax (qRunIO)+import Language.Haskell.TH.Syntax qualified as TH import RIO.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) import RIO.FilePath (combine, joinPath)+import RIO.List qualified as List+import RIO.Map qualified as Map import RIO.State (StateT, evalStateT, get, put) -import qualified Language.Haskell.TH.Syntax as TH-import qualified RIO.List as List-import qualified RIO.Map as Map- data Scope = Files | Dirs@@ -42,11 +42,7 @@ where mkPattern fp fs = fmap concat $ for fs \segments -> do- let- name =- TH.mkName . map (replace . toUpper) $- List.intercalate "_" segments-+ let name = TH.mkName $ patternName segments patType <- [t| FilePath |] let pat = TH.LitP . TH.StringL $ joinPath (fp : segments) @@ -55,11 +51,83 @@ , TH.PatSynD name (TH.PrefixPatSyn []) TH.ImplBidir pat ] - replace c =- if isUpper c || isDigit c then- c- else- '_'+replace :: Char -> Char+replace c =+ if isLower c || isUpper c || isDigit c then+ c+ else+ '_'++fieldName :: [[Char]] -> String+fieldName =+ map replace . List.takeWhile (/= '.') . List.intercalate "_"++patternName :: [[Char]] -> String+patternName =+ map (replace . toUpper) . List.intercalate "_"++collection :: [(String, TH.Name)] -> Scope -> FilePath -> Q [Dec]+collection prologue scope fp = do+ pattDecs <- filePatterns scope fp+ recDecs <- collectionRec prologue scope fp+ sourcesDecs <- sourcesVal prologue scope fp+ pure $ mconcat [recDecs, pattDecs, sourcesDecs]++collectionRec :: [(String, TH.Name)] -> Scope -> FilePath -> Q [Dec]+collectionRec prologue = mkDeclsWith mkRecord+ where+ mkRecord _fp fs = do+ let+ mkConstr = recC collName $+ map mkInclude prologue ++ map mkField (List.sort fs)++ appViaGen1 <- viaStrategy (conT (TH.mkName "Generically1") `appT` conT collName)+ let+ derivs =+ [ derivClause Nothing $ map (conT . TH.mkName) ["Show", "Functor", "Foldable", "Traversable", "Generic1"]+ , derivClause (Just appViaGen1) [conT $ TH.mkName "Applicative"]+ ]+ collectionData <- dataD mempty collName [plainTV a] Nothing [mkConstr] derivs+ pure [collectionData]++ mkField segments =+ varBangType (TH.mkName $ fieldName segments) (a')++ mkInclude (f, t) =+ varBangType (TH.mkName f) . bangType_ $+ conT t `appT` varT a++ a = TH.mkName "a"+ a' = bangType_ $ varT a++ bangType_ = bangType (bang noSourceUnpackedness noSourceStrictness)++collName :: TH.Name+collName = TH.mkName "Collection"++sourcesVal :: [(String, TH.Name)] -> Scope -> FilePath -> Q [Dec]+sourcesVal prologue = mkDeclsWith mkVal+ where+ sources = TH.mkName "sources"+ mkVal _fp fs = do+ sig <- sigD sources $ conT collName `appT`conT (TH.mkName "Source")+ let body = recConE collName $ map prologueSource prologue <> map sourceVal fs+ fun <- funD sources [clause [] (normalB body) []]+ pure [sig, fun]+ prologueSource (fn, cn) =+ pure (TH.mkName fn, TH.VarE $ samePkg cn "sources")++ sourceVal segments = (TH.mkName $ fieldName segments,) <$> mkSrc+ where+ mkSrc = [| File Nothing $val |]+ val = conE . TH.mkName $ patternName segments++samePkg :: TH.Name -> String -> TH.Name+samePkg (TH.Name _occ nf) identifier =+ TH.Name (TH.mkOccName identifier) $+ case nf of+ TH.NameG _ns _pkg mn -> TH.NameQ mn+ _ -> nf mkDeclsWith :: (FilePath -> [[String]] -> Q [Dec])
src/Resource/Texture.hs view
@@ -11,6 +11,7 @@ , TextureLayers(..) -- * Utilities+ , fromAllocatedImage , debugNameCollection , TextureLoader @@ -53,7 +54,7 @@ instance Exception TextureError -data Texture tag = Texture+data Texture layers = Texture { tFormat :: Vk.Format , tMipLevels :: Word32 , tLayers :: Word32 -- ^ Actual number of layers, up to @ArrayOf a@@@ -82,6 +83,26 @@ -- * Allocation wrappers +-- | Check that the image has a proper number of layers and lift its properties.+fromAllocatedImage+ :: forall layers m+ . ( TextureLayers layers+ , MonadThrow m+ )+ => AllocatedImage+ -> m (Texture layers)+fromAllocatedImage image = do+ unless (expectedLayers == image.aiImageRange.layerCount) $+ throwM $ ArrayError expectedLayers image.aiImageRange.layerCount+ pure Texture+ { tFormat = image.aiFormat+ , tMipLevels = image.aiImageRange.levelCount+ , tLayers = expectedLayers+ , tAllocatedImage = image+ }+ where+ expectedLayers = textureLayers @layers+ debugNameCollection :: ( Traversable t , MonadVulkan env m@@ -184,17 +205,17 @@ -- * Helpers {-# INLINE withSize2d #-}-withSize2d :: Num i => (i -> i -> a) -> Texture tag -> a+withSize2d :: Num i => (i -> i -> a) -> Texture layers -> a withSize2d f t = f (fromIntegral width) (fromIntegral height) where Vk.Extent3D{width, height} =- Image.aiExtent (tAllocatedImage t)+ t.tAllocatedImage.aiExtent {-# INLINE withSize3d #-}-withSize3d :: Num i => (i -> i -> i -> a) -> Texture tag -> a+withSize3d :: Num i => (i -> i -> i -> a) -> Texture layers -> a withSize3d f t = f (fromIntegral width)@@ -202,8 +223,8 @@ (fromIntegral depth) where Vk.Extent3D{width, height, depth} =- Image.aiExtent (tAllocatedImage t)+ t.tAllocatedImage.aiExtent -instance HasField "size" (Texture tag) Vec2 where+instance HasField "size" (Texture layers) Vec2 where {-# INLINE getField #-} getField = withSize2d vec2