keid-core 0.1.6.1 → 0.1.7.0

raw patch · 15 files changed

+1479/−492 lines, 15 filesdep +containersdep +spirv-reflect-typesdep +spirv-reflect-yamlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, spirv-reflect-types, spirv-reflect-yaml

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• keid-core.cabal +11/−2
• src/Engine/SpirV/Compile.hs +86/−0
• src/Engine/SpirV/Reflect.hs +338/−0
• src/Engine/Stage/Bootstrap/Setup.hs +11/−57
• src/Engine/Stage/Bootstrap/Types.hs +0/−27
• src/Engine/Stage/Component.hs +115/−0
• src/Engine/Vulkan/Pipeline.hs +8/−381
• src/Engine/Vulkan/Pipeline/Compute.hs +38/−8
• src/Engine/Vulkan/Pipeline/External.hs +337/−0
• src/Engine/Vulkan/Pipeline/Graphics.hs +447/−0
• src/Engine/Vulkan/Pipeline/Raytrace.hs +38/−0
• src/Engine/Vulkan/Pipeline/Stages.hs +15/−0
• src/Engine/Vulkan/Shader.hs +11/−3
• src/Render/Code.hs +14/−14

@@ -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.

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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+    }

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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+    }

@@ -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

@@ -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} =

@@ -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