keid-core 0.1.1.0 → 0.1.1.1

raw patch · 5 files changed

+76/−4 lines, 5 files

Files

• ChangeLog.md +7/−0
• keid-core.cabal +1/−1
• src/Engine/Types.hs +13/−1
• src/Engine/Vulkan/Pipeline.hs +12/−2
• src/Engine/Worker.hs +43/−0

@@ -1,5 +1,12 @@ # Changelog for keid-core +## 0.1.1.1++- Added `spawnMergeT` to merge traversable collections.+- Added `HasStateRef` to make stage state accessible from `StageFrameRIO`.+- Added module labels to pipelines and their layouts.+- Fixed VK_HOST_OUT_OF_MEMORY due to zero cubemap descriptors provided in Basic pipelines.+ ## 0.1.1.0  - Added `--display NUM` to application arguments.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.1.0+version:        0.1.1.1 synopsis:       Core parts of Keid engine. category:       Game Engine author:         IC Rainbow

@@ -5,7 +5,7 @@ import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as ResourceT import Graphics.UI.GLFW qualified as GLFW-import RIO.App (App, appEnv)+import RIO.App (App, appEnv, appState) import RIO.Lens (_1) import UnliftIO.Resource (MonadResource, ReleaseKey) import Vulkan.Core10 qualified as Vk@@ -85,6 +85,18 @@ type StageSetupRIO = RIO (App GlobalHandles (Maybe SwapchainResources))  type StageFrameRIO rp p rr st = RIO (App GlobalHandles st, Frame rp p rr)++instance HasStateRef st (App GlobalHandles st, Frame rp p rr) where+  stateRefL =+    lens+      (appState . fst)+      (\(app, frame) st' ->+          ( app+              { appState = st'+              }+          , frame+          )+      )  data Stage rp p rr st = forall a . Stage   { sTitle :: Text

@@ -21,12 +21,14 @@ 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)@@ -84,20 +86,21 @@   :: ( MonadVulkan env m      , MonadResource m      , HasRenderPass renderpass+     , HasCallStack      )   => Maybe Vk.Extent2D   -> Vk.SampleCountFlagBits   -> Config dsl vertices instances   -> renderpass   -> m (ReleaseKey, Pipeline dsl vertices instances)-allocate extent msaa config renderpass = do+allocate extent msaa config renderpass = withFrozenCallStack do   ctx <- ask   Resource.allocate     (create ctx extent msaa renderpass config)     (destroy ctx)  create-  :: (MonadIO io, HasVulkan ctx, HasRenderPass renderpass)+  :: (MonadIO io, HasVulkan ctx, HasRenderPass renderpass, HasCallStack)   => ctx   -> Maybe Vk.Extent2D   -> Vk.SampleCountFlagBits@@ -105,6 +108,11 @@   -> Config dsl vertices instances   -> 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@@ -122,6 +130,7 @@    -- TODO: get from outside   layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing+  Debug.nameObject device layout originModule    let     codeStages = Vector.fromList $ case (cVertexCode, cFragmentCode) of@@ -152,6 +161,7 @@       case Vector.toList pipelines of         [one] -> do           destroyShader context shader+          Debug.nameObject device one originModule           pure Pipeline             { pipeline     = one             , pLayout      = Tagged layout

@@ -38,6 +38,7 @@   , spawnMerge2   , spawnMerge3   , spawnMerge4+  , spawnMergeT    , ObserverIO   , newObserverIO@@ -569,6 +570,48 @@     }   where     mkVersion a b c d = mconcat [vVersion a, vVersion b, vVersion c, vVersion d]++{- |+  Spawn a merge over a homogeneous traversable collection of processes.++  A merging function will receive a collection of outputs to summarize.+-}+spawnMergeT+  :: ( Traversable t+     , HasOutput input+     , MonadUnliftIO m+     )+  => (t (GetOutput input) -> output)+  -> t input+  -> m (Merge output)+spawnMergeT f inputs = do+  output <- atomically do+    initial <- traverse (readTVar . getOutput) inputs++    newTVar Versioned+      { vVersion = foldMap vVersion initial+      , vData    = f (fmap vData initial)+      }++  worker <- forkIO $+    forever $ atomically do+      next <- traverse (readTVar . getOutput) inputs+      old <- readTVar output++      let nextVersion = foldMap vVersion next++      if nextVersion > vVersion old then+        writeTVar output Versioned+          { vVersion = nextVersion+          , vData    = f (fmap vData next)+          }+      else+        retrySTM++  pure Merge+    { mWorker = worker+    , mOutput = output+    }  -- * Demand