diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Changelog for keid-core +## 0.1.7.0 + +- Graphics pipelines extracted to `Engine.Vulkan.Pipeline.Graphics`. +- Added pipeline stage collections and `StageInfo` class. + * Shader creation can now pluck stage flags from the collection. +- Added `Engine.Vulkan.Pipeline.Raytrace` stages (no pipelines yet). +- Added `Engine.Vulkan.Pipeline.External` worker for reloading pipelines. +- Added `Engine.SpirV.Reflect` to facilitate safe reloads using `spirv-reflect` toolchain. +- Added `Engine.Engine.Stage.Component` with rendering/resources/scenes decoupled. + ## 0.1.6.1 - Minimal `vulkan` version is now 3.17. diff --git a/keid-core.cabal b/keid-core.cabal --- a/keid-core.cabal +++ b/keid-core.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: keid-core -version: 0.1.6.1 +version: 0.1.7.0 synopsis: Core parts of Keid engine. category: Game Engine homepage: https://keid.haskell-game.dev @@ -41,8 +41,10 @@ Engine.Setup Engine.Setup.Device Engine.Setup.Window + Engine.SpirV.Compile + Engine.SpirV.Reflect Engine.Stage.Bootstrap.Setup - Engine.Stage.Bootstrap.Types + Engine.Stage.Component Engine.StageSwitch Engine.Types Engine.Types.Options @@ -52,6 +54,10 @@ Engine.Vulkan.DescSets Engine.Vulkan.Pipeline Engine.Vulkan.Pipeline.Compute + Engine.Vulkan.Pipeline.External + Engine.Vulkan.Pipeline.Graphics + Engine.Vulkan.Pipeline.Raytrace + Engine.Vulkan.Pipeline.Stages Engine.Vulkan.Shader Engine.Vulkan.Swapchain Engine.Vulkan.Types @@ -154,6 +160,7 @@ , base >=4.7 && <5 , binary , bytestring + , containers , cryptohash-md5 , derive-storable , derive-storable-plugin @@ -168,6 +175,8 @@ , rio >=0.1.12.0 , rio-app , serialise + , spirv-reflect-types + , spirv-reflect-yaml , tagged , template-haskell , text diff --git a/src/Engine/SpirV/Compile.hs b/src/Engine/SpirV/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Engine/SpirV/Compile.hs @@ -0,0 +1,86 @@ +module Engine.SpirV.Compile + ( glsl + , glslStages + , glslPipelines + ) where + +import RIO + +import RIO.ByteString qualified as ByteString +import RIO.Directory (createDirectoryIfMissing, doesFileExist) +import RIO.FilePath ((<.>), ()) +import RIO.Map qualified as Map +import RIO.Process (HasProcessContext, proc, readProcess_) +import RIO.Text qualified as Text + +import Render.Code (Code(..)) +import Engine.Vulkan.Pipeline.Stages qualified as Stages + +glsl + :: ( HasLogFunc env + , HasProcessContext env + ) + => Maybe FilePath + -> Text + -> Text + -> Code + -> RIO env () +glsl outdir basename stage (Code source) = do + withDir \dir -> do + let + shaderFile = dir Text.unpack basename <.> Text.unpack stage + outFile = shaderFile <.> "spv" + outBytes = encodeUtf8 source + + exists <- doesFileExist shaderFile + same <- + if exists then do + oldBytes <- ByteString.readFile shaderFile + pure $ oldBytes == outBytes + else + pure False + + unless same do + ByteString.writeFile shaderFile outBytes + (_out, _err) <- proc + "glslangValidator" + [ "--target-env", "vulkan1.2" + , "-S", Text.unpack stage + , "-V", shaderFile + , "-o", outFile + ] + readProcess_ + logDebug $ displayShow (_out, _err) + where + withDir action = + case outdir of + Nothing -> + withSystemTempDirectory "keid-shader" action + Just dir -> do + createDirectoryIfMissing True dir + action dir + +glslStages + :: ( Stages.StageInfo stages + , HasLogFunc env + , HasProcessContext env + ) + => Maybe FilePath + -> Text + -> stages (Maybe Code) + -> RIO env () +glslStages outdir basename stages = + for_ (Stages.withLabels stages) \(label, mstage) -> + traverse_ (glsl outdir basename label) mstage + +glslPipelines + :: ( Stages.StageInfo stages + , HasLogFunc env + , HasProcessContext env + ) + => Maybe FilePath + -> Map Text (stages (Maybe Code)) + -> RIO env () +glslPipelines outdir = traverse_ compile . Map.toList + where + compile (label, stages) = glslStages outdir label stages diff --git a/src/Engine/SpirV/Reflect.hs b/src/Engine/SpirV/Reflect.hs new file mode 100644 --- /dev/null +++ b/src/Engine/SpirV/Reflect.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Engine.SpirV.Reflect where + +import RIO + +import Data.IntMap qualified as IntMap +import Data.List qualified as List +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.InterfaceVariable (InterfaceVariable) +import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified as Module +import Data.SpirV.Reflect.Traits qualified as Traits +import Data.SpirV.Reflect.TypeDescription qualified as TypeDescription +import Data.SpirV.Reflect.Yaml qualified as ReflectYaml +import Data.Tree (Tree(..)) +import Engine.Vulkan.Pipeline.Stages (StageInfo(..), withLabels) +import RIO.Process (HasProcessContext, proc, readProcess_) +import RIO.Text qualified as Text +import Vulkan.Core10.Enums.Format qualified as VkFormat + +invoke + :: ( HasProcessContext env + , HasLogFunc env + , MonadReader env m + , MonadIO m + ) + => FilePath + -> m Module +invoke file = do + (out, _err) <- proc + "spirv-reflect" + [ "-v" + , "1" + , "--yaml" + , file + ] + readProcess_ + + ReflectYaml.loadBytes ("spirv-reflect < " <> file) out + +data Reflect stages = Reflect + { bindMap :: BindMap BlockBinding + , interfaces :: StageInterface stages + , inputStage :: Text + , inputs :: InterfaceBinds + } + +-- | @layout(set=X, binding=Y) ...@ +type BindMap a = IntMap (IntMap a) + +type StageInterface stages = stages (Maybe (InterfaceBinds, InterfaceBinds)) + +-- | @layout(location=N) +type InterfaceBinds = IntMap InterfaceBinding + +deriving instance (Eq (StageInterface stages)) => Eq (Reflect stages) +deriving instance (Show (StageInterface stages)) => Show (Reflect stages) + +-- * Block variables + +-- | @uniform Foo { ... } foo;@ +type BlockBinding = + ( Text + , Enums.DescriptorType + , Tree ([Maybe Text], BlockSignature) + ) + +data BlockSignature = BlockSignature + { offset :: Word32 + , size :: Word32 + , flags :: Enums.TypeFlags + , scalar :: Maybe Traits.Scalar + } + deriving (Eq, Ord, Show) + +stagesBindMap + :: ( MonadIO m + , MonadReader env m + , HasLogFunc env + , StageInfo stages + ) + => stages (Maybe Module) + -> m (BindMap BlockBinding) +stagesBindMap = fmap snd . foldM collect ([] :: [Text], mempty) . annotate + where + annotate modules = (,) + <$> stageNames + <*> modules + + collect acc@(visited, old) (source, stageModule) = + case stageModule of + Nothing -> + pure acc + Just new -> + case unionDS old (moduleBindMap new) of + Left (six, bix, inAcc, inNew) -> do + logError $ mconcat + [ "incompatible data at " + , "layout(" + , "set=", display six + , ", " + , "binding=", display bix + , ")" + ] + logError $ "old: " <> displayDS inAcc + logError $ " from " <> displayShow visited + logError $ "new: " <> displayDS inNew + logError $ " from " <> displayShow source + throwString "catch this" + Right matching -> + pure (visited <> [source], matching) + + unionDS = + bindMapUnionWith \(_, adt, asig) (_, bdt, bsig) -> + adt == bdt && + fmap snd asig == fmap snd bsig + + displayDS (name, dt, sigs) = mconcat + [ display name + , " :: " + , maybe (displayShow dt) display $ + Enums.descriptorTypeName @Text dt + , " -- " + , displayShow . toList $ + sigs <&> \(path, BlockSignature{..}) -> + ( Text.intercalate "|" (catMaybes path) + , (size, offset, Enums.typeFlagsNames @Text flags) + , scalar + ) + ] + +moduleBindMap :: Module -> BindMap BlockBinding +moduleBindMap refl = IntMap.fromList do + ds <- toList $ Module.descriptor_sets refl + pure + ( fromIntegral $ DescriptorSet.set ds + , IntMap.fromList do + db <- toList $ DescriptorSet.bindings ds + let + DescriptorBinding.DescriptorBinding + {binding, name, descriptor_type, block} = db + pure + ( fromIntegral binding + , ( name + , descriptor_type + , blockTree [] block + ) + ) + ) + +blockTree + :: [Maybe Text] + -> BlockVariable.BlockVariable + -> Tree ([Maybe Text], BlockSignature) +blockTree ancestors bv = Node (path, here) $ map (blockTree path) there + where + here = BlockSignature + { offset = BlockVariable.offset bv + , size = BlockVariable.size bv + , .. + } + where + (flags, scalar) = + case BlockVariable.type_description bv of + Nothing -> + (Enums.TYPE_FLAG_UNDEFINED, Nothing) + Just td -> + ( TypeDescription.type_flags td + , do + TypeDescription.Traits{numeric} <- TypeDescription.traits td + let st@Traits.Scalar{width} = Traits.scalar numeric + guard $ width > 0 + pure st + ) + + path = + ancestors ++ [BlockVariable.name bv] + + there = + toList $ BlockVariable.members bv + +{-# INLINE bindMapUnionWith #-} +bindMapUnionWith + :: (a -> a -> Bool) + -> BindMap a + -> BindMap a + -> Either (Int, Int, a, a) (BindMap a) +bindMapUnionWith compatible as bs = traverse sequence validated + where + validated = + IntMap.unionWithKey + (IntMap.unionWithKey . check) + (wrap as) + (wrap bs) + + wrap = fmap (fmap pure) + + check six bix a' b' = do + a <- a' + b <- b' + if compatible a b then + Right a + else + Left (six, bix, a, b) + +-- * Interface variables + +type InterfaceBinding = + ( Maybe Text + , [Text] + , InterfaceSignature + ) + +data InterfaceSignature = InterfaceSignature + { format :: VkFormat.Format + , flags :: Enums.TypeFlags + , matrix :: Maybe Traits.Matrix + } + deriving (Eq, Ord, Show) + +stagesInterfaceMap + :: ( MonadIO m + , Traversable stages + ) + => stages (Maybe Module) + -> m (StageInterface stages) +stagesInterfaceMap = traverse $ traverse (pure . moduleInterfaceBinds) + +moduleInterfaceBinds :: Module -> (InterfaceBinds, InterfaceBinds) +moduleInterfaceBinds refl = + ( interfaceBinds Enums.StorageClassInput (Module.input_variables refl) + , interfaceBinds Enums.StorageClassOutput (Module.output_variables refl) + ) + +interfaceBinds :: Enums.StorageClass -> Vector InterfaceVariable -> InterfaceBinds +interfaceBinds cls vars = IntMap.fromList do + var@InterfaceVariable.InterfaceVariable{location} <- toList vars + guard $ InterfaceVariable.storage_class var == cls + + let + td = InterfaceVariable.type_description var + Enums.Format format = InterfaceVariable.format var + flags = maybe Enums.TYPE_FLAG_UNDEFINED TypeDescription.type_flags td + + stuff = do + TypeDescription.TypeDescription{traits} <- td + TypeDescription.Traits{numeric} <- traits + let + mt@Traits.Matrix{column_count, row_count} = Traits.matrix numeric + guard $ column_count > 0 && row_count > 0 + pure mt + + signature = InterfaceSignature + { format = VkFormat.Format $ fromIntegral format + , flags = flags + , matrix = stuff + } + + pure + ( fromIntegral location + , ( InterfaceVariable.name var + , Enums.typeFlagsNames @Text flags + , signature + ) + ) + +type IncompatibleInterfaces label = (label, label, Int, Maybe (InterfaceSignature, InterfaceSignature)) +type CompatibleInterfaces label = (label, label, IntMap ([Text], Matching (Maybe Text))) +type Matching a = Either (a, a) a + +interfaceCompatible + :: ( StageInfo stages + , IsString label + ) + => StageInterface stages + -> Either (IncompatibleInterfaces label) [CompatibleInterfaces label] +interfaceCompatible staged = + for chained \((inputLabel, input), (outputLabel, output)) -> do + checked <- for (IntMap.assocs input) \(location, requested) -> + case IntMap.lookup location output of + Just provided -> do + let + (rName, rFlags, rSignature) = requested + (pName, _pFlags, pSignature) = provided + if rSignature == pSignature then + let + names = + if rName == pName then + Right rName + else + Left (rName, pName) + in + Right (location, (rFlags, names)) + else + Left + ( inputLabel + , outputLabel + , location + , Just (rSignature, pSignature) + ) + Nothing -> + Left + ( inputLabel + , outputLabel + , location + , Nothing + ) + Right + ( outputLabel + , inputLabel + , IntMap.fromList checked + ) + + where + chained = zip (drop 1 ins) outs + + (ins, outs) = + List.unzip do + (label, Just binds) <- toList $ withLabels staged + pure + ( (label, fst binds) + , (label, snd binds) + ) + +inputStageInterface + :: (StageInfo stages, IsString label) + => StageInterface stages + -> Maybe (label, InterfaceBinds) +inputStageInterface staged = listToMaybe active + where + active = do + (label, Just binds) <- toList $ withLabels staged + pure (label, fst binds) diff --git a/src/Engine/Stage/Bootstrap/Setup.hs b/src/Engine/Stage/Bootstrap/Setup.hs --- a/src/Engine/Stage/Bootstrap/Setup.hs +++ b/src/Engine/Stage/Bootstrap/Setup.hs @@ -5,18 +5,13 @@ import RIO -import Control.Monad.Trans.Resource (ResourceT) import UnliftIO.Resource qualified as Resource -import Vulkan.Core10 qualified as Vk -import Vulkan.NamedType ((:::)) -import Engine.Types (StackStage(..), StageRIO, StageFrameRIO) +import Engine.Stage.Component qualified as Stage +import Engine.Types (StackStage(..)) import Engine.Types qualified as Engine -import Engine.Vulkan.Types (Queues) import Engine.StageSwitch (trySwitchStage) -import Engine.Stage.Bootstrap.Types (NoRendering(..), NoPipelines(..), NoResources(..), NoState(..)) - stackStage :: (a -> StackStage) -> Engine.StageSetupRIO a @@ -26,48 +21,18 @@ bootstrapStage :: (a -> StackStage) -> Engine.StageSetupRIO a - -> Engine.Stage NoRendering NoPipelines NoResources NoState -bootstrapStage handoff action = Engine.Stage - { sTitle = "Bootstrap" - - , sAllocateRP = noRendering - , sAllocateP = noPipelines - , sInitialRS = transitState handoff action - , sInitialRR = noFrameResources - - , sBeforeLoop = pure () - , sUpdateBuffers = noUpdates - , sRecordCommands = noCommands - , sAfterLoop = pure - } - -noRendering :: swapchain -> ResourceT (StageRIO st) NoRendering -noRendering _swapchain = - pure NoRendering - -noPipelines :: swapchain -> NoRendering -> ResourceT (StageRIO st) NoPipelines -noPipelines _swapchain NoRendering = - pure NoPipelines - -noCommands - :: Vk.CommandBuffer - -> rd - -> "image index" ::: Word32 - -> StageFrameRIO rp p rd st () -noCommands _cb _rd _index = - pure () - -noUpdates - :: st - -> rd - -> StageFrameRIO rp p rd st () -noUpdates _st _rd = - pure () + -> Engine.Stage Stage.NoRenderPass Stage.NoPipelines Stage.NoFrameResources Stage.NoRunState +bootstrapStage handoff action = Stage.assemble "Bootstrap" Stage.noRendering resources Nothing + where + resources = Stage.noResources + { Stage.rInitialRS = + transitState handoff action + } transitState :: (a -> StackStage) -> Engine.StageSetupRIO a - -> Engine.StageSetupRIO (Resource.ReleaseKey, NoState) + -> Engine.StageSetupRIO (Resource.ReleaseKey, Stage.NoRunState) transitState handoff action = do res <- action @@ -78,15 +43,4 @@ logError "Bootstrap switch failed" key <- Resource.register $ pure () - pure (key, NoState) - -noFrameResources - :: Queues Vk.CommandPool - -> renderPasses - -> pipelines - -> ResourceT (StageRIO rs) NoResources -noFrameResources _queues _rp _p = - fmap snd $! - Resource.allocate - (pure NoResources) - (\NoResources -> pure ()) + pure (key, Stage.NoRunState) diff --git a/src/Engine/Stage/Bootstrap/Types.hs b/src/Engine/Stage/Bootstrap/Types.hs deleted file mode 100644 --- a/src/Engine/Stage/Bootstrap/Types.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Engine.Stage.Bootstrap.Types - ( Stage - - , NoRendering(..) - , NoPipelines(..) - , NoResources(..) - , NoState(..) - ) where - -import RIO - -import Engine.Vulkan.Types (RenderPass(..)) -import Engine.Types qualified as Engine - -data NoRendering = NoRendering - -instance RenderPass NoRendering where - updateRenderpass _context = pure - refcountRenderpass _rp = pure () - -data NoPipelines = NoPipelines - -type Stage = Engine.Stage NoRendering NoPipelines NoResources NoState - -data NoResources = NoResources - -data NoState = NoState diff --git a/src/Engine/Stage/Component.hs b/src/Engine/Stage/Component.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Stage/Component.hs @@ -0,0 +1,115 @@ +module Engine.Stage.Component where + +import RIO + +import Control.Monad.Trans.Resource (ResourceT) +import Data.Semigroup (Semigroup(..)) +import UnliftIO.Resource (ReleaseKey, allocate) +import Vulkan.Core10 qualified as Vk +import Vulkan.NamedType ((:::)) + +import Engine.Types (Stage(..), StageFrameRIO, StageRIO) +import Engine.Vulkan.Swapchain (SwapchainResources(..)) +import Engine.Vulkan.Types qualified as Vulkan +import Resource.Region qualified as Region + +assemble + :: Foldable t + => Text + -> Rendering rp p st + -> Resources rp p st rr + -> t (Scene rp p st rr) + -> Stage rp p rr st +assemble title Rendering{..} Resources{..} (fold -> Scene{..}) = Stage + { sTitle = title + + , sAllocateRP = rAllocateRP + , sAllocateP = rAllocateP + + , sInitialRS = rInitialRS + , sInitialRR = rInitialRR + + , sBeforeLoop = Region.exec scBeforeLoop + , sUpdateBuffers = scUpdateBuffers + , sRecordCommands = scRecordCommands + , sAfterLoop = Region.release + } + +data Rendering rp p st = Rendering + { rAllocateRP :: SwapchainResources -> ResourceT (StageRIO st) rp + , rAllocateP :: SwapchainResources -> rp -> ResourceT (StageRIO st) p + } + +data NoRenderPass = NoRenderPass + +instance Vulkan.RenderPass NoRenderPass where + updateRenderpass _context = pure + refcountRenderpass _rp = pure () + +data NoPipelines = NoPipelines +type NoRendering = Rendering NoRenderPass NoPipelines + +noRendering :: NoRendering st +noRendering = Rendering + { rAllocateRP = \_swapchain -> + pure NoRenderPass + , rAllocateP = \_swapchain NoRenderPass -> + pure NoPipelines + } + +data Resources rp p st rr = Resources + { rInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st) + , rInitialRR :: Vulkan.Queues Vk.CommandPool -> rp -> p -> ResourceT (StageRIO st) rr + } + +type NoResources rp p = Resources rp p NoRunState NoFrameResources + +data NoRunState = NoRunState +data NoFrameResources = NoFrameResources + +noResources :: NoResources rp p +noResources = Resources + { rInitialRS = + allocate + (pure NoRunState) + (\NoRunState -> pure ()) + , rInitialRR = \_pool _rp _p -> + pure NoFrameResources + } + +data Scene rp p st rr = Scene + { scBeforeLoop :: ResourceT (StageRIO st) () + , scUpdateBuffers :: st -> rr -> StageFrameRIO rp p rr st () + , scRecordCommands :: Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st () + } + +instance Semigroup (Scene rp p st rr) where + a <> b = Scene + { scBeforeLoop = do + scBeforeLoop a + scBeforeLoop b + , scUpdateBuffers = \st rr -> do + scUpdateBuffers a st rr + scUpdateBuffers b st rr + , scRecordCommands = \cb rr ii -> do + scRecordCommands a cb rr ii + scRecordCommands b cb rr ii + } + + sconcat scenes = Scene + { scBeforeLoop = do + traverse_ scBeforeLoop scenes + , scUpdateBuffers = \st rr -> + for_ scenes \Scene{scUpdateBuffers} -> + scUpdateBuffers st rr + , scRecordCommands = \cb rr ii -> + for_ scenes \Scene{scRecordCommands} -> + scRecordCommands cb rr ii + } + +instance Monoid (Scene rp p st rr) where + mempty = Scene + { scBeforeLoop = pure () + , scUpdateBuffers = mempty + , scRecordCommands = mempty + } diff --git a/src/Engine/Vulkan/Pipeline.hs b/src/Engine/Vulkan/Pipeline.hs --- a/src/Engine/Vulkan/Pipeline.hs +++ b/src/Engine/Vulkan/Pipeline.hs @@ -1,48 +1,17 @@ --- XXX: TypeError in Compatible generates unused constraint argument -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - -{-# LANGUAGE OverloadedLists #-} - module Engine.Vulkan.Pipeline - ( Config(..) - , baseConfig - - , Configure - - , Pipeline(..) - , allocate - , create + ( Pipeline(..) , destroy - - , bind - - , pushPlaceholder - - , vertexInput - , attrBindings - , formatSize + , Specialization ) where import RIO -import Data.Bits ((.|.)) import Data.Kind (Type) -import Data.List qualified as List import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector -import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack) -import UnliftIO.Resource (MonadResource, ReleaseKey) -import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk -import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12 -import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&)) -import Vulkan.NamedType ((:::)) -import Vulkan.Utils.Debug qualified as Debug -import Vulkan.Zero (Zero(..)) -import Engine.Vulkan.DescSets (Bound(..), Compatible) -import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, DsLayouts, getPipelineCache) -import Engine.Vulkan.Shader qualified as Shader +import Engine.Vulkan.Types (HasVulkan(..), DsLayouts) data Pipeline (dsl :: [Type]) vertices instances = Pipeline { pipeline :: Vk.Pipeline @@ -50,284 +19,13 @@ , pDescLayouts :: Tagged dsl DsLayouts } --- * Pipeline - -type family Configure pipeline spec where - Configure (Pipeline dsl vertices instances) spec = Config dsl vertices instances spec - -data Config (dsl :: [Type]) vertices instances spec = Config - { cVertexCode :: Maybe ByteString - , cFragmentCode :: Maybe ByteString - , cVertexInput :: SomeStruct Vk.PipelineVertexInputStateCreateInfo - , cDescLayouts :: Tagged dsl [DsBindings] - , cPushConstantRanges :: Vector Vk.PushConstantRange - , cBlend :: Bool - , cDepthWrite :: Bool - , cDepthTest :: Bool - , cDepthCompare :: Vk.CompareOp - , cTopology :: Vk.PrimitiveTopology - , cCull :: Vk.CullModeFlagBits - , cDepthBias :: Maybe ("constant" ::: Float, "slope" ::: Float) - , cSpecialization :: spec - } - --- | Settings for generic triangle-rendering pipeline. -baseConfig :: Config '[] vertices instances () -baseConfig = Config - { cVertexCode = Nothing - , cFragmentCode = Nothing - , cVertexInput = zero - , cDescLayouts = Tagged [] - , cPushConstantRanges = mempty - , cBlend = False - , cDepthWrite = True - , cDepthTest = True - , cDepthCompare = Vk.COMPARE_OP_LESS - , cTopology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , cCull = Vk.CULL_MODE_BACK_BIT - , cDepthBias = Nothing - , cSpecialization = () - } - --- XXX: consider using instance attrs or uniforms -pushPlaceholder :: Vk.PushConstantRange -pushPlaceholder = Vk.PushConstantRange - { Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT .|. Vk.SHADER_STAGE_FRAGMENT_BIT - , Vk.offset = 0 - , Vk.size = 4 * dwords - } - where - -- XXX: each 4 word32s eat up one register (on AMD) - dwords = 4 - -allocate - :: ( MonadVulkan env m - , MonadResource m - , HasRenderPass renderpass - , Shader.Specialization spec - , HasCallStack - ) - => Maybe Vk.Extent2D - -> Vk.SampleCountFlagBits - -> Config dsl vertices instances spec - -> renderpass - -> m (ReleaseKey, Pipeline dsl vertices instances) -allocate extent msaa config renderpass = withFrozenCallStack do - ctx <- ask - Resource.allocate - (create ctx extent msaa renderpass config) - (destroy ctx) - -create - :: ( MonadUnliftIO io +destroy + :: ( MonadIO io , HasVulkan ctx - , HasRenderPass renderpass - , Shader.Specialization spec - , HasCallStack ) => ctx - -> Maybe Vk.Extent2D - -> Vk.SampleCountFlagBits - -> renderpass - -> Config dsl vertices instances spec - -> io (Pipeline dsl vertices instances) -create context mextent msaa renderpass Config{..} = do - let - originModule = - fromString . List.intercalate "|" $ - map (srcLocModule . snd) (getCallStack callStack) - - dsLayouts <- Vector.forM (Vector.fromList $ unTagged cDescLayouts) \bindsFlags -> do - let - (binds, flags) = List.unzip bindsFlags - - setCI = - zero - { Vk.bindings = Vector.fromList binds - } - ::& zero - { Vk12.bindingFlags = Vector.fromList flags - } - :& () - - Vk.createDescriptorSetLayout device setCI Nothing - - -- TODO: get from outside - layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing - Debug.nameObject device layout originModule - - shader <- Shader.withSpecialization cSpecialization $ - Shader.create context $ - case (cVertexCode, cFragmentCode) of - (Just vertCode, Just fragCode) -> - [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) - , (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) - ] - - (Just vertCode, Nothing) -> - [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) - ] - - (Nothing, Just fragCode) -> - -- XXX: good luck - [ (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) - ] - - (Nothing, Nothing) -> - [] - - let - cis = Vector.singleton . SomeStruct $ - pipelineCI (Shader.sPipelineStages shader) layout - - Vk.createGraphicsPipelines device cache cis Nothing >>= \case - (Vk.SUCCESS, pipelines) -> - case Vector.toList pipelines of - [one] -> do - Shader.destroy context shader - Debug.nameObject device one originModule - pure Pipeline - { pipeline = one - , pLayout = Tagged layout - , pDescLayouts = Tagged dsLayouts - } - _ -> - error "assert: exactly one pipeline requested" - (err, _) -> - error $ "createGraphicsPipelines: " <> show err - where - device = getDevice context - cache = getPipelineCache context - - layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo - { flags = zero - , setLayouts = dsLayouts - , pushConstantRanges = cPushConstantRanges - } - - pipelineCI stages layout = zero - { Vk.stages = stages - , Vk.vertexInputState = Just cVertexInput - , Vk.inputAssemblyState = Just inputAsembly - , Vk.viewportState = Just $ SomeStruct viewportState - , Vk.rasterizationState = Just $ SomeStruct rasterizationState - , Vk.multisampleState = Just $ SomeStruct multisampleState - , Vk.depthStencilState = Just depthStencilState - , Vk.colorBlendState = Just $ SomeStruct colorBlendState - , Vk.dynamicState = dynamicState - , Vk.layout = layout - , Vk.renderPass = getRenderPass renderpass - , Vk.subpass = 0 - , Vk.basePipelineHandle = zero - } - where - inputAsembly = zero - { Vk.topology = cTopology - , Vk.primitiveRestartEnable = restartable - } - - restartable = elem @Set cTopology - [ Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP - , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP - , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN - ] - - (viewportState, dynamicState) = case mextent of - Nothing -> - ( zero - { Vk.viewportCount = 1 - , Vk.scissorCount = 1 - } - , Just zero - { Vk.dynamicStates = Vector.fromList - [ Vk.DYNAMIC_STATE_VIEWPORT - , Vk.DYNAMIC_STATE_SCISSOR - ] - } - ) - Just extent@Vk.Extent2D{width, height} -> - ( zero - { Vk.viewports = Vector.fromList - [ Vk.Viewport - { Vk.x = 0 - , Vk.y = 0 - , Vk.width = realToFrac width - , Vk.height = realToFrac height - , Vk.minDepth = 0 - , Vk.maxDepth = 1 - } - ] - , Vk.scissors = Vector.singleton Vk.Rect2D - { Vk.offset = Vk.Offset2D 0 0 - , extent = extent - } - } - , Nothing - ) - - rasterizationState = case cDepthBias of - Nothing -> - rasterizationBase - Just (constantFactor, slopeFactor) -> - rasterizationBase - { Vk.depthBiasEnable = True - , Vk.depthBiasConstantFactor = constantFactor - , Vk.depthBiasSlopeFactor = slopeFactor - } - - rasterizationBase = zero - { Vk.depthClampEnable = False - , Vk.rasterizerDiscardEnable = False - , Vk.lineWidth = 1 - , Vk.polygonMode = Vk.POLYGON_MODE_FILL - , Vk.cullMode = cCull - , Vk.frontFace = Vk.FRONT_FACE_CLOCKWISE - , Vk.depthBiasEnable = False - } - - multisampleState = zero - { Vk.rasterizationSamples = msaa - , Vk.sampleShadingEnable = enable - , Vk.minSampleShading = if enable then 0.2 else 1.0 - , Vk.sampleMask = Vector.singleton maxBound - } - where - enable = True -- TODO: check and enable sample rate shading feature - - depthStencilState = zero - { Vk.depthTestEnable = cDepthTest - , Vk.depthWriteEnable = cDepthWrite - , Vk.depthCompareOp = cDepthCompare - , Vk.depthBoundsTestEnable = False - , Vk.minDepthBounds = 0.0 -- Optional - , Vk.maxDepthBounds = 1.0 -- Optional - , Vk.stencilTestEnable = False - , Vk.front = zero -- Optional - , Vk.back = zero -- Optional - } - - colorBlendState = zero - { Vk.logicOpEnable = - False - , Vk.attachments = Vector.singleton zero - { Vk.blendEnable = cBlend - , Vk.srcColorBlendFactor = Vk.BLEND_FACTOR_ONE - , Vk.dstColorBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA - , Vk.colorBlendOp = Vk.BLEND_OP_ADD - , Vk.srcAlphaBlendFactor = Vk.BLEND_FACTOR_ONE - , Vk.dstAlphaBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA - , Vk.alphaBlendOp = Vk.BLEND_OP_ADD - , Vk.colorWriteMask = colorRgba - } - } - - colorRgba = - Vk.COLOR_COMPONENT_R_BIT .|. - Vk.COLOR_COMPONENT_G_BIT .|. - Vk.COLOR_COMPONENT_B_BIT .|. - Vk.COLOR_COMPONENT_A_BIT - -destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Pipeline dsl vertices instances -> io () + -> Pipeline dsl vertices instances + -> io () destroy context Pipeline{..} = do Vector.forM_ (unTagged pDescLayouts) \dsLayout -> Vk.destroyDescriptorSetLayout device dsLayout Nothing @@ -336,75 +34,4 @@ where device = getDevice context -bind - :: ( Compatible pipeLayout boundLayout - , MonadIO m - ) - => Vk.CommandBuffer - -> Pipeline pipeLayout vertices instances - -> Bound boundLayout vertices instances m () - -> Bound boundLayout oldVertices oldInstances m () -bind cb Pipeline{pipeline} (Bound attrAction) = do - Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline - Bound attrAction - -vertexInput :: [(Vk.VertexInputRate, [Vk.Format])] -> SomeStruct Vk.PipelineVertexInputStateCreateInfo -vertexInput bindings = SomeStruct zero - { Vk.vertexBindingDescriptions = binds - , Vk.vertexAttributeDescriptions = attrs - } - where - binds = Vector.fromList do - (ix, (rate, formats)) <- zip [0..] bindings - pure Vk.VertexInputBindingDescription - { binding = ix - , stride = sum $ map formatSize formats - , inputRate = rate - } - - attrs = attrBindings $ map snd bindings - --- * Utils - -attrBindings :: [[Vk.Format]] -> Vector Vk.VertexInputAttributeDescription -attrBindings bindings = mconcat $ List.unfoldr shiftLocations (0, 0, bindings) - where - shiftLocations = \case - (_binding, _lastLoc, []) -> Nothing - (binding, lastLoc, formats : rest) -> Just (bound, next) - where - bound = Vector.fromList do - (ix, format) <- zip [0..] formats - let offset = sum . map formatSize $ take ix formats - pure zero - { Vk.binding = binding - , Vk.location = fromIntegral $ lastLoc + ix - , Vk.format = format - , Vk.offset = offset - } - - next = - ( binding + 1 - , lastLoc + Vector.length bound - , rest - ) - -formatSize :: Integral a => Vk.Format -> a -formatSize = \case - Vk.FORMAT_R32G32B32A32_SFLOAT -> 16 - Vk.FORMAT_R32G32B32_SFLOAT -> 12 - Vk.FORMAT_R32G32_SFLOAT -> 8 - Vk.FORMAT_R32_SFLOAT -> 4 - - Vk.FORMAT_R32G32B32A32_UINT -> 16 - Vk.FORMAT_R32G32B32_UINT -> 12 - Vk.FORMAT_R32G32_UINT -> 8 - Vk.FORMAT_R32_UINT -> 4 - - Vk.FORMAT_R32G32B32A32_SINT -> 16 - Vk.FORMAT_R32G32B32_SINT -> 12 - Vk.FORMAT_R32G32_SINT -> 8 - Vk.FORMAT_R32_SINT -> 4 - - format -> - error $ "Format size unknown: " <> show format +type family Specialization pipeline diff --git a/src/Engine/Vulkan/Pipeline/Compute.hs b/src/Engine/Vulkan/Pipeline/Compute.hs --- a/src/Engine/Vulkan/Pipeline/Compute.hs +++ b/src/Engine/Vulkan/Pipeline/Compute.hs @@ -7,6 +7,13 @@ ( Config(..) , Configure + , Stages(..) + , stageNames + , stageFlagBits + , StageCode + , StageSpirv + , StageReflect + , Pipeline(..) , allocate , create @@ -22,6 +29,7 @@ import Data.List qualified as List import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector +import GHC.Generics (Generic1) import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack) import UnliftIO.Resource (MonadResource, ReleaseKey) import UnliftIO.Resource qualified as Resource @@ -31,11 +39,14 @@ import Vulkan.Utils.Debug qualified as Debug import Vulkan.Zero (Zero(..)) +import Engine.SpirV.Reflect (Reflect) import Engine.Vulkan.DescSets (Bound(..), Compatible) -import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsBindings, getPipelineCache) - import Engine.Vulkan.Pipeline (Pipeline(..), destroy) +import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader +import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsBindings, getPipelineCache) +import Render.Code (Code) +import Resource.Collection (Generically1(..)) data Config (dsl :: [Type]) spec = Config { cComputeCode :: ByteString @@ -49,6 +60,25 @@ type family Configure pipeline spec where Configure (Pipeline dsl Compute Compute) spec = Config dsl spec +newtype Stages a = Stages + { comp :: a -- ^ compute + } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1) + deriving Applicative via (Generically1 Stages) + +instance StageInfo Stages where + stageNames = Stages + { comp = "comp" + } + + stageFlagBits = Stages + { comp = Vk.SHADER_STAGE_COMPUTE_BIT + } + +type StageCode = Stages (Maybe Code) +type StageSpirv = Stages (Maybe ByteString) +type StageReflect = Reflect Stages + allocate :: ( MonadVulkan env m , MonadResource m @@ -100,9 +130,9 @@ -- Compute stuff begins... shader <- Shader.withSpecialization cSpecialization $ - Shader.create - context - [(Vk.SHADER_STAGE_COMPUTE_BIT, cComputeCode)] + Shader.create context Stages + { comp = Just cComputeCode + } let cis = Vector.singleton . SomeStruct $ @@ -149,9 +179,9 @@ , MonadIO m ) => Vk.CommandBuffer - -> Pipeline pipeLayout vertices instances - -> Bound boundLayout vertices instances m () - -> Bound boundLayout oldVertices oldInstances m () + -> Pipeline pipeLayout Compute Compute + -> Bound boundLayout Compute Compute m () + -> Bound boundLayout noVertices noInstances m () bind cb Pipeline{pipeline} (Bound attrAction) = do Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_COMPUTE pipeline Bound attrAction diff --git a/src/Engine/Vulkan/Pipeline/External.hs b/src/Engine/Vulkan/Pipeline/External.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Pipeline/External.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Engine.Vulkan.Pipeline.External + ( Process + , spawn + , spawnReflect + + , loadConfig + , loadConfigReflect + + , Observer + + , newObserverGraphics + , observeGraphics + + , newObserverCompute + , observeCompute + + , type (^) + , ConfigureGraphics + , ConfigureCompute + , Observers + , observeField + + , dumpPipelines + ) where + +import RIO + +import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, release) +import Data.List (maximum) +import Data.Tagged (Tagged(..)) +import RIO.ByteString qualified as ByteString +import RIO.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist) +import RIO.Map qualified as Map +import RIO.Process (HasProcessContext) +import RIO.Text qualified as Text +import RIO.Time (UTCTime, getCurrentTime) +import RIO.FilePath ((), (<.>)) +import Vulkan.Core10 qualified as Vk + +import Render.Code (Code(..)) +import Engine.SpirV.Reflect qualified as Reflect +import Engine.Types (StageFrameRIO, StageRIO) +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 (DsBindings, HasRenderPass) +import Engine.Worker qualified as Worker + +type Process config = Worker.Timed () config + +spawn + :: ( Foldable stages + , MonadUnliftIO m + , MonadReader env m + , HasLogFunc env + ) + => (stages (Maybe FilePath) -> m stuff) + -> Text + -> stages (Maybe FilePath) + -> (stuff -> config) + -> m (Process config) +spawn loader label stageFiles makeConfig = + Worker.spawnTimed startActive dtF initF stepF () + where + startActive = True + + dtF = Left 1e6 + + initF () = do + logDebug $ "Starting pipeline watch on " <> display label + + result <- loader stageFiles + initialTime <- getCurrentTime + pure (makeConfig result, initialTime) + + stepF oldTime () = do + checkTime oldTime (catMaybes $ toList stageFiles) >>= \case + Nothing -> + -- logDebug $ "Skipping pipeline update from " <> display label + pure (Nothing, oldTime) + Just newTime -> do + logInfo $ "Updating pipeline from " <> display label + try (loader stageFiles) >>= \case + Left (SomeException err) -> do + logError $ displayShow err + pure (Nothing, newTime) + Right result -> + pure + ( Just $ makeConfig result + , newTime + ) + +spawnReflect + :: ( MonadUnliftIO m + , MonadReader env m + , HasLogFunc env + , HasProcessContext env + , StageInfo stages + ) + => Text + -> stages (Maybe FilePath) + -> ((stages (Maybe ByteString), Reflect.Reflect stages) -> config) + -> m (Process config) +spawnReflect = spawn loadConfigReflect + +checkTime + :: MonadIO io + => UTCTime + -> [FilePath] + -> io (Maybe UTCTime) +checkTime oldTime = fmap collect . traverse getModificationTime + where + collect = \case + [] -> + Nothing + (maximum -> maxTime) -> + if maxTime <= oldTime then + Nothing + else + Just maxTime + +loadConfig + :: ( Traversable stages + , MonadIO io + ) + => stages (Maybe FilePath) + -> io (stages (Maybe ByteString)) +loadConfig stageFiles = + for stageFiles $ + traverse ByteString.readFile + +loadConfigReflect + :: ( StageInfo stages + , MonadIO io + , MonadReader env io + , HasLogFunc env + , HasProcessContext env + ) + => stages (Maybe FilePath) + -> io (stages (Maybe ByteString), Reflect.Reflect stages) +loadConfigReflect stageFiles = do + stageCode <- loadConfig stageFiles + + -- TODO: use stageCode? + stageRefl <- for stageFiles $ + traverse Reflect.invoke + + reflDS <- Reflect.stagesBindMap stageRefl + + reflIS <- Reflect.stagesInterfaceMap stageRefl + case Reflect.interfaceCompatible reflIS of + Right ok -> + logDebug $ displayShow ok + Left (inputStage, outputStage, location, err) -> do + let + between = "Between " <> inputStage <> " and " <> outputStage + locInfo = "(location=" <> show location <> ")" + case err of + Nothing -> + throwString $ + unwords [ between, locInfo <> ":", "missing output" ] + Just (sigRequested, sigProvided) -> + throwString $ unlines + [ unwords [ between, locInfo <> ":", "incompatible signatures" ] + , " requested: " <> show sigRequested + , " provided: " <> show sigProvided + ] + + (inputStage, inputs) <- + case Reflect.inputStageInterface reflIS of + Nothing -> + throwString "No active stage" + Just found -> + pure found + + let + reflect = Reflect.Reflect + { bindMap = reflDS + , interfaces = reflIS + , inputStage = inputStage + , inputs = inputs + } + pure + ( stageCode + , reflect + ) + +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 + ) + => renderpass + -> Vk.SampleCountFlagBits + -> worker + -> ResourceT (StageRIO rs) (Observer pipeline) +newObserverGraphics rp msaa process = do + initialConfig <- Worker.getOutputData process + + initial <- Graphics.allocate + Nothing + msaa + initialConfig + rp + + Worker.newObserverIO initial + +observeGraphics + :: ( HasRenderPass renderpass + , Worker.HasOutput output + , Worker.GetOutput output ~ Graphics.Configure pipeline + , pipeline ~ Graphics.Pipeline dsl vertices instances + , spec ~ Graphics.Specialization pipeline + , Shader.Specialization spec + ) + => renderpass + -> Vk.SampleCountFlagBits + -> Tagged dsl [DsBindings] + -> output + -> 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" + release oldKey + mapRIO fst $ Graphics.allocate + Nothing + msaa + ( config + { Graphics.cDescLayouts = sceneBinds + } + ) + rp + +newObserverCompute + :: ( config ~ Compute.Configure pipeline () + , pipeline ~ Compute.Pipeline dsl Compute Compute + ) + => Process config + -> ResourceT (StageRIO rs) (Observer pipeline) +newObserverCompute process = do + initialConfig <- Worker.getOutputData process + + initial <- Compute.allocate initialConfig + + Worker.newObserverIO initial + +observeCompute + :: ( Worker.HasOutput output + , Worker.GetOutput output ~ config + , Shader.Specialization spec + , config ~ Compute.Configure pipeline spec + , pipeline ~ Compute.Pipeline dsl Compute Compute + ) + => Tagged dsl [DsBindings] + -> output + -> Worker.ObserverIO (ReleaseKey, pipeline) + -> StageFrameRIO rp p fr rs () +observeCompute binds configP output = + void $! Worker.observeIO configP output \(oldKey, _old) config -> do + logDebug "Rebuilding pipeline" + release oldKey + mapRIO fst $ Compute.allocate config + { Compute.cDescLayouts = binds + } + +-- * HKD wrappers + +data ConfigureGraphics p +data ConfigureCompute p +data Observers p + +type family f ^ p where + Identity ^ p = p + ConfigureGraphics ^ p = Process (Graphics.Configure p) + ConfigureCompute ^ p = Process (Compute.Configure p ()) + Observers ^ p = Observer p + f ^ p = f p + +observeField + :: forall + pf + p + renderpass + dsl + s vs is + rps ps fr rs + . ( p ~ Graphics.Pipeline s vs is + , Shader.Specialization (Graphics.Specialization p) + , HasRenderPass renderpass + ) + => renderpass + -> Vk.SampleCountFlagBits + -> Tagged dsl DsBindings + -> pf ConfigureGraphics + -> pf Observers + -> (forall a . pf a -> a ^ p) + -> StageFrameRIO rps ps fr rs () +observeField rp msaa binds workers observers field = + observeGraphics + rp + msaa + (Tagged [unTagged binds]) + (field @ConfigureGraphics workers) + (field @Observers observers) + +dumpPipelines + :: StageInfo t + => MonadIO io + => FilePath + -> Map Text (t (Maybe Code)) + -> io () +dumpPipelines prefix pipelines = do + createDirectoryIfMissing True prefix + for_ (Map.toList pipelines) \(pipeline, stageCode) -> do + let stages = (,) <$> stageNames <*> stageCode + for_ stages \(stage, mcode) -> + for_ mcode \(Code code) -> do + let + file = prefix Text.unpack pipeline <.> stage + bytes = encodeUtf8 code + exists <- doesFileExist file + if exists then do + old <- ByteString.readFile file + unless (bytes == old) $ + ByteString.writeFile file bytes + else + ByteString.writeFile file bytes diff --git a/src/Engine/Vulkan/Pipeline/Graphics.hs b/src/Engine/Vulkan/Pipeline/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Pipeline/Graphics.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE UndecidableInstances #-} + +-- XXX: TypeError in Compatible generates unused constraint argument +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Engine.Vulkan.Pipeline.Graphics + ( Config(..) + , baseConfig + + , Configure + , Pipeline.Specialization + + , vertexInput + , formatSize + , pushPlaceholder + + , Stages(..) + , stageNames + , stageFlagBits + , basicStages + , vertexOnly + , StageCode + , StageSpirv + , StageReflect + + , Pipeline(..) + , allocate + , create + , Pipeline.destroy + + , bind + ) where + +import RIO + +import Data.Bits ((.|.)) +import Data.Kind (Type) +import Data.List qualified as List +import Data.Tagged (Tagged(..)) +import Data.Vector qualified as Vector +import GHC.Generics (Generic1) +import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack) +import UnliftIO.Resource (MonadResource, ReleaseKey) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12 +import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&)) +import Vulkan.NamedType ((:::)) +import Vulkan.Utils.Debug qualified as Debug +import Vulkan.Zero (Zero(..)) + +import Engine.SpirV.Reflect (Reflect) +import Engine.Vulkan.DescSets (Bound(..), Compatible) +import Engine.Vulkan.Pipeline (Pipeline(..)) +import Engine.Vulkan.Pipeline qualified as Pipeline +import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) +import Engine.Vulkan.Shader qualified as Shader +import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, getPipelineCache) +import Render.Code (Code) +import Resource.Collection (Generically1(..)) + +data Stages a = Stages + { vert :: a -- ^ vertex + , tesc :: a -- ^ tessellation control + , tese :: a -- ^ tessellation evaluation + , geom :: a -- ^ geometry + , frag :: a -- ^ fragment + } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1) + deriving Applicative via (Generically1 Stages) + +instance StageInfo Stages where + stageNames = Stages + { vert = "vert" + , tesc = "tesc" + , tese = "tese" + , geom = "geom" + , frag = "frag" + } + + stageFlagBits = Stages + { vert = Vk.SHADER_STAGE_VERTEX_BIT + , tesc = Vk.SHADER_STAGE_TESSELLATION_CONTROL_BIT + , tese = Vk.SHADER_STAGE_TESSELLATION_EVALUATION_BIT + , geom = Vk.SHADER_STAGE_GEOMETRY_BIT + , frag = Vk.SHADER_STAGE_FRAGMENT_BIT + } + +basicStages + :: "vert" ::: a + -> "frag" ::: a + -> Stages (Maybe a) +basicStages v f = (pure Nothing) + { vert = Just v + , frag = Just f + } + +vertexOnly + :: "vert" ::: a + -> Stages (Maybe a) +vertexOnly v = (pure Nothing) + { vert = Just v + } + +type StageCode = Stages (Maybe Code) +type StageSpirv = Stages (Maybe ByteString) +type StageReflect = Reflect Stages + +type family Configure pipeline where + Configure (Pipeline dsl vertices instances) = + Config + dsl + vertices + instances + (Pipeline.Specialization (Pipeline dsl vertices instances)) + +data Config (dsl :: [Type]) vertices instances spec = Config + { cStages :: StageSpirv + , cReflect :: Maybe StageReflect + , cVertexInput :: SomeStruct Vk.PipelineVertexInputStateCreateInfo + , cDescLayouts :: Tagged dsl [DsBindings] + , cPushConstantRanges :: Vector Vk.PushConstantRange + , cBlend :: Bool + , cDepthWrite :: Bool + , cDepthTest :: Bool + , cDepthCompare :: Vk.CompareOp + , cTopology :: Vk.PrimitiveTopology + , cCull :: Vk.CullModeFlagBits + , cDepthBias :: Maybe ("constant" ::: Float, "slope" ::: Float) + , cSpecialization :: spec + } + +-- | Settings for generic triangle-rendering pipeline. +baseConfig :: Config '[] vertices instances () +baseConfig = Config + { cStages = pure Nothing + , cVertexInput = zero + , cReflect = Nothing + , cDescLayouts = Tagged [] + , cPushConstantRanges = mempty + , cBlend = False + , cDepthWrite = True + , cDepthTest = True + , cDepthCompare = Vk.COMPARE_OP_LESS + , cTopology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , cCull = Vk.CULL_MODE_BACK_BIT + , cDepthBias = Nothing + , cSpecialization = () + } + +-- XXX: consider using instance attrs or uniforms +pushPlaceholder :: Vk.PushConstantRange +pushPlaceholder = Vk.PushConstantRange + { Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT .|. Vk.SHADER_STAGE_FRAGMENT_BIT + , Vk.offset = 0 + , Vk.size = 4 * dwords + } + where + -- XXX: each 4 word32s eat up one register (on AMD) + dwords = 4 + +allocate + :: ( config ~ Configure pipeline + , pipeline ~ Pipeline dsl vertices instances + , spec ~ Pipeline.Specialization pipeline + , Shader.Specialization spec + , HasCallStack + , MonadVulkan env m + , MonadResource m + , HasRenderPass renderpass + ) + => Maybe Vk.Extent2D + -> Vk.SampleCountFlagBits + -> Config dsl vertices instances spec + -> renderpass + -> m (ReleaseKey, pipeline) +allocate extent msaa config renderpass = withFrozenCallStack do + ctx <- ask + Resource.allocate + (create ctx extent msaa renderpass config) + (Pipeline.destroy ctx) + +create + :: ( MonadUnliftIO io + , HasVulkan ctx + , HasRenderPass renderpass + , Shader.Specialization spec + , HasCallStack + ) + => ctx + -> Maybe Vk.Extent2D + -> Vk.SampleCountFlagBits + -> renderpass + -> Config dsl vertices instances spec + -> io (Pipeline dsl vertices instances) +create context mextent msaa renderpass Config{..} = do + let + originModule = + fromString . List.intercalate "|" $ + map (srcLocModule . snd) (getCallStack callStack) + + dsLayouts <- Vector.forM (Vector.fromList $ unTagged cDescLayouts) \bindsFlags -> do + let + (binds, flags) = List.unzip bindsFlags + + setCI = + zero + { Vk.bindings = Vector.fromList binds + } + ::& zero + { Vk12.bindingFlags = Vector.fromList flags + } + :& () + + Vk.createDescriptorSetLayout device setCI Nothing + + -- TODO: get from outside + layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing + Debug.nameObject device layout originModule + + shader <- Shader.withSpecialization cSpecialization $ + Shader.create context cStages + + let + cis = Vector.singleton . SomeStruct $ + pipelineCI (Shader.sPipelineStages shader) layout + + Vk.createGraphicsPipelines device cache cis Nothing >>= \case + (Vk.SUCCESS, pipelines) -> + case Vector.toList pipelines of + [one] -> do + Shader.destroy context shader + Debug.nameObject device one originModule + pure Pipeline + { pipeline = one + , pLayout = Tagged layout + , pDescLayouts = Tagged dsLayouts + } + _ -> + error "assert: exactly one pipeline requested" + (err, _) -> + error $ "createGraphicsPipelines: " <> show err + where + device = getDevice context + cache = getPipelineCache context + + layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo + { flags = zero + , setLayouts = dsLayouts + , pushConstantRanges = cPushConstantRanges + } + + pipelineCI stages layout = zero + { Vk.stages = stages + , Vk.vertexInputState = Just cVertexInput + , Vk.inputAssemblyState = Just inputAsembly + , Vk.viewportState = Just $ SomeStruct viewportState + , Vk.rasterizationState = Just $ SomeStruct rasterizationState + , Vk.multisampleState = Just $ SomeStruct multisampleState + , Vk.depthStencilState = Just depthStencilState + , Vk.colorBlendState = Just $ SomeStruct colorBlendState + , Vk.dynamicState = dynamicState + , Vk.layout = layout + , Vk.renderPass = getRenderPass renderpass + , Vk.subpass = 0 + , Vk.basePipelineHandle = zero + } + where + inputAsembly = zero + { Vk.topology = cTopology + , Vk.primitiveRestartEnable = restartable + } + + restartable = elem @Set cTopology + [ Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP + , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP + , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN + ] + + (viewportState, dynamicState) = case mextent of + Nothing -> + ( zero + { Vk.viewportCount = 1 + , Vk.scissorCount = 1 + } + , Just zero + { Vk.dynamicStates = Vector.fromList + [ Vk.DYNAMIC_STATE_VIEWPORT + , Vk.DYNAMIC_STATE_SCISSOR + ] + } + ) + Just extent@Vk.Extent2D{width, height} -> + ( zero + { Vk.viewports = Vector.fromList + [ Vk.Viewport + { Vk.x = 0 + , Vk.y = 0 + , Vk.width = realToFrac width + , Vk.height = realToFrac height + , Vk.minDepth = 0 + , Vk.maxDepth = 1 + } + ] + , Vk.scissors = Vector.singleton Vk.Rect2D + { Vk.offset = Vk.Offset2D 0 0 + , extent = extent + } + } + , Nothing + ) + + rasterizationState = case cDepthBias of + Nothing -> + rasterizationBase + Just (constantFactor, slopeFactor) -> + rasterizationBase + { Vk.depthBiasEnable = True + , Vk.depthBiasConstantFactor = constantFactor + , Vk.depthBiasSlopeFactor = slopeFactor + } + + rasterizationBase = zero + { Vk.depthClampEnable = False + , Vk.rasterizerDiscardEnable = False + , Vk.lineWidth = 1 + , Vk.polygonMode = Vk.POLYGON_MODE_FILL + , Vk.cullMode = cCull + , Vk.frontFace = Vk.FRONT_FACE_CLOCKWISE + , Vk.depthBiasEnable = False + } + + multisampleState = zero + { Vk.rasterizationSamples = msaa + , Vk.sampleShadingEnable = enable + , Vk.minSampleShading = if enable then 0.2 else 1.0 + , Vk.sampleMask = Vector.singleton maxBound + } + where + enable = True -- TODO: check and enable sample rate shading feature + + depthStencilState = zero + { Vk.depthTestEnable = cDepthTest + , Vk.depthWriteEnable = cDepthWrite + , Vk.depthCompareOp = cDepthCompare + , Vk.depthBoundsTestEnable = False + , Vk.minDepthBounds = 0.0 -- Optional + , Vk.maxDepthBounds = 1.0 -- Optional + , Vk.stencilTestEnable = False + , Vk.front = zero -- Optional + , Vk.back = zero -- Optional + } + + colorBlendState = zero + { Vk.logicOpEnable = + False + , Vk.attachments = Vector.singleton zero + { Vk.blendEnable = cBlend + , Vk.srcColorBlendFactor = Vk.BLEND_FACTOR_ONE + , Vk.dstColorBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA + , Vk.colorBlendOp = Vk.BLEND_OP_ADD + , Vk.srcAlphaBlendFactor = Vk.BLEND_FACTOR_ONE + , Vk.dstAlphaBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA + , Vk.alphaBlendOp = Vk.BLEND_OP_ADD + , Vk.colorWriteMask = colorRgba + } + } + + colorRgba = + Vk.COLOR_COMPONENT_R_BIT .|. + Vk.COLOR_COMPONENT_G_BIT .|. + Vk.COLOR_COMPONENT_B_BIT .|. + Vk.COLOR_COMPONENT_A_BIT + +bind + :: ( Compatible pipeLayout boundLayout + , MonadIO m + ) + => Vk.CommandBuffer + -> Pipeline pipeLayout vertices instances + -> Bound boundLayout vertices instances m () + -> Bound boundLayout oldVertices oldInstances m () +bind cb Pipeline{pipeline} (Bound attrAction) = do + Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline + Bound attrAction + +vertexInput :: [(Vk.VertexInputRate, [Vk.Format])] -> SomeStruct Vk.PipelineVertexInputStateCreateInfo +vertexInput bindings = SomeStruct zero + { Vk.vertexBindingDescriptions = binds + , Vk.vertexAttributeDescriptions = attrs + } + where + binds = Vector.fromList do + (ix, (rate, formats)) <- zip [0..] bindings + pure Vk.VertexInputBindingDescription + { binding = ix + , stride = sum $ map formatSize formats + , inputRate = rate + } + + attrs = attrBindings $ map snd bindings + +-- * Utils + +attrBindings :: [[Vk.Format]] -> Vector Vk.VertexInputAttributeDescription +attrBindings bindings = mconcat $ List.unfoldr shiftLocations (0, 0, bindings) + where + shiftLocations = \case + (_binding, _lastLoc, []) -> Nothing + (binding, lastLoc, formats : rest) -> Just (bound, next) + where + bound = Vector.fromList do + (ix, format) <- zip [0..] formats + let offset = sum . map formatSize $ take ix formats + pure zero + { Vk.binding = binding + , Vk.location = fromIntegral $ lastLoc + ix + , Vk.format = format + , Vk.offset = offset + } + + next = + ( binding + 1 + , lastLoc + Vector.length bound + , rest + ) + +formatSize :: Integral a => Vk.Format -> a +formatSize = \case + Vk.FORMAT_R32G32B32A32_SFLOAT -> 16 + Vk.FORMAT_R32G32B32_SFLOAT -> 12 + Vk.FORMAT_R32G32_SFLOAT -> 8 + Vk.FORMAT_R32_SFLOAT -> 4 + + Vk.FORMAT_R32G32B32A32_UINT -> 16 + Vk.FORMAT_R32G32B32_UINT -> 12 + Vk.FORMAT_R32G32_UINT -> 8 + Vk.FORMAT_R32_UINT -> 4 + + Vk.FORMAT_R32G32B32A32_SINT -> 16 + Vk.FORMAT_R32G32B32_SINT -> 12 + Vk.FORMAT_R32G32_SINT -> 8 + Vk.FORMAT_R32_SINT -> 4 + + format -> + error $ "Format size unknown: " <> show format diff --git a/src/Engine/Vulkan/Pipeline/Raytrace.hs b/src/Engine/Vulkan/Pipeline/Raytrace.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Pipeline/Raytrace.hs @@ -0,0 +1,38 @@ +module Engine.Vulkan.Pipeline.Raytrace where + +import RIO + +import Vulkan.Core10 qualified as Vk + +import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) +import Resource.Collection (Generic1, Generically1(..)) + +data Stages a = Stages + { rgen :: a -- ^ ray generation + , rint :: a -- ^ ray intersection + , rahit :: a -- ^ ray any hit + , rchit :: a -- ^ ray closest hit + , rmiss :: a -- ^ ray miss + , rcall :: a -- ^ ray callable + } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1) + deriving Applicative via (Generically1 Stages) + +instance StageInfo Stages where + stageNames = Stages + { rgen = "rgen" + , rint = "rint" + , rahit = "rahit" + , rchit = "rchit" + , rmiss = "rmiss" + , rcall = "rcall" + } + + stageFlagBits = Stages + { rgen = Vk.SHADER_STAGE_CALLABLE_BIT_KHR + , rint = Vk.SHADER_STAGE_INTERSECTION_BIT_KHR + , rahit = Vk.SHADER_STAGE_MISS_BIT_KHR + , rchit = Vk.SHADER_STAGE_CLOSEST_HIT_BIT_KHR + , rmiss = Vk.SHADER_STAGE_ANY_HIT_BIT_KHR + , rcall = Vk.SHADER_STAGE_RAYGEN_BIT_KHR + } diff --git a/src/Engine/Vulkan/Pipeline/Stages.hs b/src/Engine/Vulkan/Pipeline/Stages.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Pipeline/Stages.hs @@ -0,0 +1,15 @@ +module Engine.Vulkan.Pipeline.Stages + ( StageInfo(..) + , withLabels + ) where + +import RIO + +import Vulkan.Core10 qualified as Vk + +class (Applicative t, Traversable t) => StageInfo t where + stageNames :: IsString label => t label + stageFlagBits :: t Vk.ShaderStageFlagBits + +withLabels :: (StageInfo t, IsString label) => t a -> t (label, a) +withLabels staged = (,) <$> stageNames <*> staged 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 @@ -23,6 +23,7 @@ import Vulkan.Zero (Zero(..)) import Unsafe.Coerce (unsafeCoerce) +import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Types (HasVulkan(..)) data Shader = Shader @@ -31,13 +32,16 @@ } create - :: (MonadIO io, HasVulkan ctx) + :: ( MonadIO io + , HasVulkan ctx + , StageInfo t + ) => ctx - -> Vector (Vk.ShaderStageFlagBits, ByteString) + -> t (Maybe ByteString) -> Maybe Vk.SpecializationInfo -> io Shader create context stages spec = do - staged <- Vector.forM stages \(stage, code) -> do + staged <- Vector.forM collected \(stage, code) -> do module_ <- Vk.createShaderModule (getDevice context) zero @@ -59,6 +63,10 @@ { sModules = modules , sPipelineStages = pStages } + where + collected = Vector.fromList do + (stage, Just code) <- toList $ (,) <$> stageFlagBits <*> stages + pure (stage, code) destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io () destroy context Shader{sModules} = diff --git a/src/Render/Code.hs b/src/Render/Code.hs --- a/src/Render/Code.hs +++ b/src/Render/Code.hs @@ -1,12 +1,12 @@ {-# OPTIONS_GHC -fno-prof-auto #-} module Render.Code - ( compileVert - , compileFrag - , compileComp + ( Code(..) , glsl , trimming - , Code(..) + , compileVert + , compileFrag + , compileComp ) where import RIO @@ -16,18 +16,18 @@ import RIO.Text qualified as Text import Vulkan.Utils.ShaderQQ.GLSL.Glslang (compileShaderQ, glsl) -compileVert :: String -> Q Exp -compileVert = compileShaderQ Nothing "vert" Nothing - -compileFrag :: String -> Q Exp -compileFrag = compileShaderQ Nothing "frag" Nothing - -compileComp :: String -> Q Exp -compileComp = compileShaderQ Nothing "comp" Nothing - -- | A wrapper to `show` code into `compileShaderQ` vars. newtype Code = Code { unCode :: Text } - deriving (Eq, Ord) + deriving (Eq, Ord, IsString) instance Show Code where show = Text.unpack . unCode + +compileVert :: Code -> Q Exp +compileVert = compileShaderQ Nothing "vert" Nothing . Text.unpack . unCode + +compileFrag :: Code -> Q Exp +compileFrag = compileShaderQ Nothing "frag" Nothing . Text.unpack . unCode + +compileComp :: Code -> Q Exp +compileComp = compileShaderQ Nothing "comp" Nothing . Text.unpack . unCode