diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/keid-core.cabal b/keid-core.cabal --- a/keid-core.cabal +++ b/keid-core.cabal @@ -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.* diff --git a/src/Engine/Events/CursorPos.hs b/src/Engine/Events/CursorPos.hs --- a/src/Engine/Events/CursorPos.hs +++ b/src/Engine/Events/CursorPos.hs @@ -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) diff --git a/src/Engine/Events/MouseButton.hs b/src/Engine/Events/MouseButton.hs --- a/src/Engine/Events/MouseButton.hs +++ b/src/Engine/Events/MouseButton.hs @@ -6,7 +6,6 @@ import RIO -import Data.Type.Equality (type (~)) import Geomancy (Vec2) import UnliftIO.Resource (ReleaseKey) diff --git a/src/Engine/Types/Options.hs b/src/Engine/Types/Options.hs --- a/src/Engine/Types/Options.hs +++ b/src/Engine/Types/Options.hs @@ -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 diff --git a/src/Engine/Vulkan/Pipeline/External.hs b/src/Engine/Vulkan/Pipeline/External.hs --- a/src/Engine/Vulkan/Pipeline/External.hs +++ b/src/Engine/Vulkan/Pipeline/External.hs @@ -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 diff --git a/src/Engine/Vulkan/Pipeline/Graphics.hs b/src/Engine/Vulkan/Pipeline/Graphics.hs --- a/src/Engine/Vulkan/Pipeline/Graphics.hs +++ b/src/Engine/Vulkan/Pipeline/Graphics.hs @@ -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 diff --git a/src/Engine/Vulkan/Shader.hs b/src/Engine/Vulkan/Shader.hs --- a/src/Engine/Vulkan/Shader.hs +++ b/src/Engine/Vulkan/Shader.hs @@ -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 diff --git a/src/Engine/Vulkan/Types.hs b/src/Engine/Vulkan/Types.hs --- a/src/Engine/Vulkan/Types.hs +++ b/src/Engine/Vulkan/Types.hs @@ -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 diff --git a/src/Engine/Worker.hs b/src/Engine/Worker.hs --- a/src/Engine/Worker.hs +++ b/src/Engine/Worker.hs @@ -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 diff --git a/src/Render/Pass/Offscreen.hs b/src/Render/Pass/Offscreen.hs --- a/src/Render/Pass/Offscreen.hs +++ b/src/Render/Pass/Offscreen.hs @@ -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 diff --git a/src/Resource/Buffer.hs b/src/Resource/Buffer.hs --- a/src/Resource/Buffer.hs +++ b/src/Resource/Buffer.hs @@ -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 diff --git a/src/Resource/Image.hs b/src/Resource/Image.hs --- a/src/Resource/Image.hs +++ b/src/Resource/Image.hs @@ -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 diff --git a/src/Resource/Image/Downsample.hs b/src/Resource/Image/Downsample.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Image/Downsample.hs @@ -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 + } diff --git a/src/Resource/Source.hs b/src/Resource/Source.hs --- a/src/Resource/Source.hs +++ b/src/Resource/Source.hs @@ -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 diff --git a/src/Resource/Static.hs b/src/Resource/Static.hs --- a/src/Resource/Static.hs +++ b/src/Resource/Static.hs @@ -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]) diff --git a/src/Resource/Texture.hs b/src/Resource/Texture.hs --- a/src/Resource/Texture.hs +++ b/src/Resource/Texture.hs @@ -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