vulkan-utils-framegraph (empty) → 0.1.0.0

raw patch · 11 files changed

+2952/−0 lines, 11 filesdep +basedep +containersdep +fragr

Dependencies added: base, containers, fragr, resourcet, tasty, tasty-hunit, text, transformers, vector, vulkan, vulkan-utils, vulkan-utils-framegraph

Files

• LICENSE +30/−0
• README.md +47/−0
• package.yaml +58/−0
• src/Vulkan/Utils/FrameGraph/Aliasing.hs +151/−0
• src/Vulkan/Utils/FrameGraph/Buffer.hs +412/−0
• src/Vulkan/Utils/FrameGraph/Driver.hs +460/−0
• src/Vulkan/Utils/FrameGraph/Image.hs +680/−0
• src/Vulkan/Utils/FrameGraph/Recorder.hs +354/−0
• src/Vulkan/Utils/FrameGraph/Swapchain.hs +71/−0
• test/Spec.hs +586/−0
• vulkan-utils-framegraph.cabal +103/−0

@@ -0,0 +1,30 @@+Copyright IC Rainbow (c) 2026++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of IC Rainbow nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,47 @@+# vulkan-utils-framegraph++Vulkan adapter for the [`fragr`](https://gitlab.com/dpwiz/fragr) frame graph:+resource types whose `preRead` / `preWrite` hooks place `cmdPipelineBarrier`+image transitions automatically, so passes declare *what* they access and the+graph records the barriers.++`Vulkan.Utils.FrameGraph.Image` provides `ManagedImage` — an image plus a+tracked `ImageState` (layout, stage, access). Declare an access with a `Usage`+(encoded into `Fragr.Flags` via `usageFlags`); the hook diffs the tracked+state against the usage's target and emits the transition, then updates the+tracked state.++```haskell+import Fragr qualified as FG+import Vulkan.Utils.FrameGraph.Image (ImageDesc (..), Usage (..), newManagedImage, usageFlags)++offscreen <- newManagedImage image Vk.IMAGE_ASPECT_COLOR_BIT+h <- FG.importResource g "offscreen" (ImageDesc "offscreen") offscreen+h' <- -- in a pass setup: FG.writeWith h (usageFlags ColorAttachment)+      -- a later pass: FG.readWith h' (usageFlags SampledFragment)+```++`Ctx ManagedImage` is the `CommandBuffer` the barriers record into; run the+graph with `FG.execute g cmdBuffer ()`.++## Scope++`ManagedImage` participates as an *imported* resource: the graph tracks its+layout and places barriers but does not own its allocation. Graph-owned+transient images with deferred (frames-in-flight-safe) reclamation are future+work — that needs `FG.executeQueued` + a `RecycleQueue`, since single-queue+`execute` would free a transient during recording, before the GPU has run.++The layout-diff model inserts a barrier whenever the target `ImageState`+differs from the tracked one, and also for every write access with the state+unchanged (same-state WAW); only read-after-read skips the barrier.++When consecutive accesses land on different queues the barrier's source scope+is replaced by the destination stage with no access mask: execution ordering+and memory availability must come from the driver's inter-queue semaphore, and+the barrier chains to its wait. Two caveats follow: the submit wait's+`dstStageMask` must cover the consuming usage's stage, and cross-queue-family+access is only supported for CONCURRENT-shared images — no ownership+release/acquire pair is emitted (`PassSync` acquires/releases are dropped by+`recordingBackend`), so an EXCLUSIVE image's contents are undefined on the new+family.

@@ -0,0 +1,58 @@+name: vulkan-utils-framegraph+version: "0.1.0.0"+synopsis: Vulkan barrier-placement and resource adapter for the fragr frame graph+category: Graphics+maintainer: IC Rainbow <aenor.realm@gmail.com>+license: BSD-3-Clause+github: haskell-game/vulkan+license-file: LICENSE+extra-source-files:+- README.md+- package.yaml++library:+  source-dirs: src+  dependencies:+  - base >= 4.16 && <5+  - containers+  - fragr+  - resourcet+  - text+  - transformers+  - vector+  - vulkan >= 3.27 && < 3.28+  - vulkan-utils++ghc-options:+- -Wall++default-extensions:+- BlockArguments+- DerivingStrategies+- DuplicateRecordFields+- ImportQualifiedPost+- LambdaCase+- NamedFieldPuns+- NoFieldSelectors+- OverloadedLists+- OverloadedRecordDot+- OverloadedStrings+- RecordWildCards+- ScopedTypeVariables+- StrictData+- TypeApplications+- TypeFamilies++tests:+  vulkan-utils-framegraph-test:+    main: Spec.hs+    source-dirs: test+    dependencies:+    - base+    - containers+    - vector+    - vulkan+    - vulkan-utils-framegraph+    - fragr+    - tasty+    - tasty-hunit

@@ -0,0 +1,151 @@+{-| Plan-time memory aliasing for graph-owned transients.++Two entries whose lifetimes cannot overlap may share one allocation, decided+from the compiled schedule before anything is recorded — no run-time+reclamation, because a backend's @destroyResource@ fires while /recording/,+long before the GPU is done with the memory.++The raw material is 'FG.EntryInfo.live': each entry's first and last+executing pass, as positions in execution order. Disjoint ranges are+necessary but __not sufficient__, and the gap is the whole point of this+module: positions order the executing passes /globally/, while passes on+different queues run concurrently. Two ranges can be disjoint in position+and still overlap in time.++So aliasing rides on the schedule's happens-before relation, not on the+positions: entry @a@ may hand its memory to @b@ only if @a@'s last pass+happens-before @b@'s first — same queue (submission order, plus the takeover+barrier), or a timeline wait that transitively orders the two. 'happensBefore'+derives exactly that from the 'FG.PassSync' waits the compiler already emits.++The caller supplies the compatibility classes (size, alignment, memory type):+'planAliases' only answers "may these share", and returns each group in+takeover order so the backend can seed the newcomer's barrier from its+predecessor's final state.+-}+module Vulkan.Utils.FrameGraph.Aliasing+  ( Candidate (..)+  , planAliases+  , happensBefore+  , Schedule+  , scheduleOf+  ) where++import Data.List (sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector qualified as V+import Data.Word (Word64)++import Fragr qualified as FG++{- | An entry in the running for aliasing: its id and its live range, as+inclusive positions into the executing passes ('FG.EntryInfo.live').++Only entries the graph /owns/ belong here — an import's memory is the+caller's whatever its range says ('FG.EntryInfo.imported' tells them apart).+-}+data Candidate = Candidate+  { entryId :: Int+  , live :: (Int, Int)+  }+  deriving (Eq, Show)++{- | The happens-before relation over one run's executing passes, indexed by+position (the same positions 'FG.EntryInfo.live' reports).++Per pass: the timeline value it signals on its own queue, and a vector clock+of what it has necessarily observed on every queue.+-}+newtype Schedule = Schedule (V.Vector (FG.QueueId, Word64, Map FG.QueueId Word64))++{- | Derive the relation from the compiled schedule.++Takes the executing passes /in execution order/ — the driver's+@mapMaybe (.sync) snapshot.passes@, which is the very list+'FG.EntryInfo.live' indexes.++Each pass observes its queue predecessor's clock and, for every 'FG.Wait',+the clock of the pass whose signal it waits on; then it stamps its own+signal. Waits carry a watermark value rather than an exact signal, so the+lookup takes the latest signal at or below it.++A wait can only name a value an earlier pass signalled (a consumer cannot+hold a handle its producer has not yet made), so the lookup always lands.+Were it ever to miss, the clock stays empty and the pass looks ordered after+nothing — fewer aliases, never an unsound one.+-}+scheduleOf :: [FG.PassSync] -> Schedule+scheduleOf syncs = Schedule (V.fromList (reverse clocks))+  where+    -- Fold in execution order, carrying: each queue's latest clock, and the+    -- clock at each (queue, signalled value) so a wait can look one up.+    (_, _, clocks) = foldl step (Map.empty, Map.empty, []) syncs++    step+      :: ( Map FG.QueueId (Map FG.QueueId Word64)+         , Map (FG.QueueId, Word64) (Map FG.QueueId Word64)+         , [(FG.QueueId, Word64, Map FG.QueueId Word64)]+         )+      -> FG.PassSync+      -> ( Map FG.QueueId (Map FG.QueueId Word64)+         , Map (FG.QueueId, Word64) (Map FG.QueueId Word64)+         , [(FG.QueueId, Word64, Map FG.QueueId Word64)]+         )+    step (latest, atValue, acc) s =+      let+        inherited = Map.findWithDefault Map.empty s.queue latest+        waited =+          [ Map.findWithDefault Map.empty (q, v') atValue+          | w <- s.waits+          , let q = w.queue+          , -- the newest signal on q at or below the watermark+          Just (v', _) <- [Map.lookupLE (q, w.value) atValue >>= keyOn q]+          ]+        merged = Map.unionsWith max (inherited : waited)+        clock = Map.insertWith max s.queue s.signal merged+      in+        ( Map.insert s.queue clock latest+        , Map.insert (s.queue, s.signal) clock atValue+        , (s.queue, s.signal, clock) : acc+        )++    -- lookupLE crosses queue boundaries in the (queue, value) key order;+    -- keep it only when it landed on the queue we asked about.+    keyOn q ((q', v), c) = if q == q' then Just (v, c) else Nothing++{- | Does the pass at the first position necessarily complete before the pass+at the second begins?++True when the second's clock has observed the first's signal — same queue+(submission order), or a wait chain that transitively reaches it.+-}+happensBefore :: Schedule -> Int -> Int -> Bool+happensBefore (Schedule passes) i j+  | i == j = False+  | otherwise = case (passes V.!? i, passes V.!? j) of+      (Just (queue, signal, _), Just (_, _, after)) ->+        Map.findWithDefault 0 queue after >= signal+      _ -> False++{- | Pack candidates into groups that may share one allocation.++The caller has already split them into a compatibility class (same memory+type, and a block big enough for the largest). Within a class, two entries+may share only if the schedule orders one's last pass before the other's+first — 'happensBefore', not merely disjoint positions.++Each group comes back in takeover order, so the backend can seed a+newcomer's aliasing barrier from its predecessor's final state (its contents+are undefined, but the memory dependency on the previous user is real).+-}+planAliases :: Schedule -> [Candidate] -> [[Candidate]]+planAliases sched = foldl place [] . sortOn (fst . (.live))+  where+    -- Greedy: first group whose every member is ordered against this one.+    place groups c = case break (all (compatible c)) groups of+      (before, g : after) -> before <> ((g <> [c]) : after)+      (before, []) -> before <> [[c]]++    compatible c m = ordered m c || ordered c m+    ordered x y = happensBefore sched (snd x.live) (fst y.live)

@@ -0,0 +1,412 @@+{-| A 'FG.Resource' for Vulkan buffers that places memory barriers automatically.++The buffer sibling of "Vulkan.Utils.FrameGraph.Image": a 'ManagedBuffer'+carries the buffer plus its tracked 'BufferState' (stage, access — buffers+have no layout), a pass declares an access with a 'Usage', and the hooks diff+the tracked state against the usage's target and queue a+@VkBufferMemoryBarrier@ into the 'Recorder''s per-pass batch. Barriers cover+the whole buffer; queue hops chain to the driver's semaphore exactly as the+image adapter's do (and cross-family access likewise needs CONCURRENT+sharing).++Import-only: the graph tracks the state and places barriers but does not own+the allocation.+-}+module Vulkan.Utils.FrameGraph.Buffer+  ( ManagedBuffer (..)+  , newManagedBuffer+  , BufferDesc (..)+  , importManagedBuffer+  , importScratchBuffer+  , importOwnedBuffer+  , describedAs+  , sharedAcrossQueues+  , BufferState (..)+  , freshState+  , Usage (..)+  , usageState+  , transitionBufferTo+  , transitionBuffersTo+  , queueTransition+  , transferOwnership+  ) where++import Control.Monad (foldM, unless, when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Bits ((.&.), (.|.))+import Data.Foldable (traverse_)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe, isNothing)+import Data.Text (Text)+import Data.Vector qualified as V++import Fragr qualified as FG+import Vulkan.CStruct.Extends (SomeStruct (..))+import Vulkan.Core10 qualified as Vk+import Vulkan.Utils.FrameGraph.Recorder (Accessor (..), Recorder, TransferSide (..), chainedNode, flushBarriers, markChained, queueBufferBarrier, recorderFamily, recorderHost, recorderQueue, recorderSameFamily)+import Vulkan.Zero (zero)++-- | A buffer whose stage/access the frame graph tracks and barriers.+data ManagedBuffer = ManagedBuffer+  { buffer :: Vk.Buffer+  , stateRef :: IORef BufferState+  , queueRef :: IORef (Maybe FG.QueueId)+  -- ^ The device queue that last accessed it; 'Nothing' until one has.+  , releasedRef :: IORef (Maybe BufferState)+  {- ^ The state a pending ownership release saw, so the acquiring half can+  build the barrier that matches it exactly.+  -}+  , shared :: Bool+  {- ^ The allocation is @SHARING_MODE_CONCURRENT@ across the families the+  graph uses it on ('sharedAcrossQueues'). An unmarked resource accessed+  across queues is fatal: no ownership transfer is emitted, so its contents+  would be undefined on the new family.+  -}+  , info :: Text+  -- ^ Human-readable summary shown by visualization output; attach with 'describedAs'.+  }++-- | Wrap a buffer, starting from 'freshState'.+{-# INLINE newManagedBuffer #-}+newManagedBuffer :: (MonadIO m) => Vk.Buffer -> m ManagedBuffer+newManagedBuffer buffer = liftIO do+  stateRef <- newIORef freshState+  queueRef <- newIORef Nothing+  releasedRef <- newIORef Nothing+  pure ManagedBuffer{releasedRef, buffer, stateRef, queueRef, shared = False, info = ""}++-- | Attach a summary shown next to the resource's name in visualization output.+describedAs :: Text -> ManagedBuffer -> ManagedBuffer+describedAs t mb = mb{info = t}++{- | Mark the allocation as @SHARING_MODE_CONCURRENT@ across the families it+is used on.++Required before any cross-family access the graph cannot transfer+ownership for: an @EXCLUSIVE@ resource's contents are undefined on the new+family, so crossing without this is fatal, not silent. Apply before+importing — imports read it through 'FG.isShared', exempting the buffer+from the schedule's single-owner validation.+-}+sharedAcrossQueues :: ManagedBuffer -> ManagedBuffer+sharedAcrossQueues mb = mb{shared = True}++instance FG.Resource ManagedBuffer where+  type Desc ManagedBuffer = BufferDesc+  type Alloc ManagedBuffer = ()+  type Ctx ManagedBuffer = Recorder+  type Flags ManagedBuffer = Usage++  createResource _ _ =+    error "ManagedBuffer is import-only: allocate the buffer and use importResource"++  destroyResource _ _ _ = pure ()++  preRead h _ usage rec mb = queueTransition rec (FG.handleId h) mb usage+  preWrite h _ usage rec mb = queueTransition rec (FG.handleId h) mb usage++  -- The two halves of a cross-queue hand-off, as in the image adapter.+  preRelease h _ usage peer rec mb = transferOwnership Release rec (FG.handleId h) peer mb usage+  preAcquire h _ usage peer rec mb = transferOwnership Acquire rec (FG.handleId h) peer mb usage++  isShared mb = mb.shared++  describeDesc d = d.info++-- | The synchronization state a buffer's last access left it in.+data BufferState = BufferState+  { stage :: Vk.PipelineStageFlags+  , access :: Vk.AccessFlags+  }+  deriving stock (Eq, Show)++{- | Never accessed on the device since the last host-synchronized point (a+fence-waited setup submit): top of pipe, no access to make available.+-}+freshState :: BufferState+freshState = BufferState Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT zero++-- | How a pass uses a buffer, i.e. the 'BufferState' it must be in for that access.+data Usage+  = -- | @vkCmdDraw*Indirect@ / @vkCmdDispatchIndirect@ command source.+    IndirectRead+  | TransferSrc+  | TransferDst+  | -- | Storage read/write in the given shader stage (compute, vertex, …).+    StorageRead Vk.PipelineStageFlags+  | StorageWrite Vk.PipelineStageFlags+  | -- | Read-modify-write storage access (atomics).+    StorageReadWrite Vk.PipelineStageFlags+  | -- | Read by the host, after the schedule's timeline wait reaches it.+    HostRead+  | -- | Written by the host (a mapped upload) before device consumers.+    HostWrite+  deriving stock (Eq, Ord, Show)++-- | The target state each 'Usage' requires.+usageState :: Usage -> BufferState+usageState = \case+  IndirectRead -> BufferState Vk.PIPELINE_STAGE_DRAW_INDIRECT_BIT Vk.ACCESS_INDIRECT_COMMAND_READ_BIT+  TransferSrc -> BufferState Vk.PIPELINE_STAGE_TRANSFER_BIT Vk.ACCESS_TRANSFER_READ_BIT+  TransferDst -> BufferState Vk.PIPELINE_STAGE_TRANSFER_BIT Vk.ACCESS_TRANSFER_WRITE_BIT+  StorageRead stage -> BufferState stage Vk.ACCESS_SHADER_READ_BIT+  StorageWrite stage -> BufferState stage Vk.ACCESS_SHADER_WRITE_BIT+  StorageReadWrite stage -> BufferState stage (Vk.ACCESS_SHADER_READ_BIT .|. Vk.ACCESS_SHADER_WRITE_BIT)+  HostRead -> BufferState Vk.PIPELINE_STAGE_HOST_BIT Vk.ACCESS_HOST_READ_BIT+  HostWrite -> BufferState Vk.PIPELINE_STAGE_HOST_BIT Vk.ACCESS_HOST_WRITE_BIT++{- | Whether the 'Usage' writes the buffer (and so needs a barrier even when the+state is unchanged — only read-after-read can skip it).+-}+usageWrites :: Usage -> Bool+usageWrites = \case+  TransferDst -> True+  StorageWrite _ -> True+  StorageReadWrite _ -> True+  HostWrite -> True+  IndirectRead -> False+  TransferSrc -> False+  StorageRead _ -> False+  HostRead -> False++{- | Record the barrier bringing the buffer into the 'Usage''s state and update+the tracked state. Standalone counterpart to the hook path, for barriers+recorded outside a pass; treats the access as same-queue.+-}+transitionBufferTo :: (MonadIO m) => Vk.CommandBuffer -> ManagedBuffer -> Usage -> m ()+{-# INLINE transitionBufferTo #-}+transitionBufferTo cb mb usage = transitionBuffersTo cb [(mb, usage)]++{- | 'transitionBufferTo' over a batch: one @vkCmdPipelineBarrier@, OR-ed stage masks.++The buffers must be distinct: barriers in one command are unordered, so two+entries for the same buffer would race.+-}+transitionBuffersTo :: (MonadIO m) => Vk.CommandBuffer -> [(ManagedBuffer, Usage)] -> m ()+transitionBuffersTo cb accesses = do+  (srcs, dsts, barriers) <- foldM collect (zero, zero, []) accesses+  unless (null barriers) $+    Vk.cmdPipelineBarrier cb srcs dsts zero [] (V.fromList barriers) []+  where+    collect acc@(srcs, dsts, barriers) (mb, usage) = do+      lastQueue <- liftIO (readIORef mb.queueRef)+      nextTransition (maybe HostAccess DeviceQueue lastQueue) (\_ _ -> True) False mb usage >>= \case+        Nothing -> pure acc+        Just (src, dst, barrier) -> pure (srcs .|. src, dsts .|. dst, barrier : barriers)++{- | The hook path: 'transitionBufferTo' rules, but queued and queue-aware.++Queue hops chain to the driver's semaphore, like the image adapter's: the+prior synchronization's scope must cover the usage's stage. Same-family+queues share freely; crossing to another /family/ needs CONCURRENT sharing+or an ownership acquire this pass performed.+-}+queueTransition :: (MonadIO m) => Recorder -> Int -> ManagedBuffer -> Usage -> m ()+queueTransition rec node mb usage = do+  queue <- recorderQueue rec+  chained0 <- chainedNode rec node+  hosted <- recorderHost rec+  sameFamily <- recorderSameFamily rec+  nextTransition (if hosted then HostAccess else DeviceQueue queue) sameFamily chained0 mb usage >>= traverse_ \(srcStage, dstStage, barrier) ->+    queueBufferBarrier rec srcStage dstStage barrier++{- | The producer- and consumer-side halves of a cross-queue hand-off.++The image adapter's rules, minus the layout: on a @CONCURRENT@ buffer the+semaphore alone orders the two sides and both halves are no-ops; on an+@EXCLUSIVE@ one they are a real queue-family ownership transfer, the same+barrier recorded in each queue's buffer with both family indices named.+The acquire advances the tracked state and marks the node chained.++A hand-off to the host is neither: the release carries the full dependency+(a semaphore signal makes device writes available to the device domain+only, so the host half needs a real @HOST@ destination scope), and the+acquire is bookkeeping.+-}+transferOwnership :: (MonadIO m) => TransferSide -> Recorder -> Int -> FG.QueueId -> ManagedBuffer -> Usage -> m ()+transferOwnership side rec node peer mb usage = do+  hosted <- recorderHost rec+  queue <- recorderQueue rec+  ourFamily <- recorderFamily rec queue+  peerFamily <- recorderFamily rec peer+  cur <- liftIO (readIORef mb.stateRef)+  released <- liftIO (readIORef mb.releasedRef)+  let+    next = usageState usage+    (srcFamily, dstFamily) = case side of+      Release -> (ourFamily, peerFamily)+      Acquire -> (peerFamily, ourFamily)+    -- The host owns nothing (it is not a family), and a CONCURRENT buffer is+    -- owned by no one.+    owned =+      not mb.shared+        && not hosted+        && srcFamily /= dstFamily+        && srcFamily /= Vk.QUEUE_FAMILY_IGNORED+        && dstFamily /= Vk.QUEUE_FAMILY_IGNORED+    -- The consumer is the host: only the release's barrier can make the+    -- device's writes visible to it (the schedule's timeline wait cannot).+    toHost = next.stage .&. Vk.PIPELINE_STAGE_HOST_BIT /= zero+    from = case side of+      Release -> cur+      Acquire -> fromMaybe cur released+    barrier =+      SomeStruct+        zero+          { Vk.srcAccessMask = case side of+              Release -> from.access+              Acquire -> zero+          , Vk.dstAccessMask = case side of+              Release -> if toHost then next.access else zero+              Acquire -> next.access+          , Vk.srcQueueFamilyIndex = if owned then srcFamily else Vk.QUEUE_FAMILY_IGNORED+          , Vk.dstQueueFamilyIndex = if owned then dstFamily else Vk.QUEUE_FAMILY_IGNORED+          , Vk.buffer = mb.buffer+          , Vk.offset = 0+          , Vk.size = Vk.WHOLE_SIZE+          }+    (srcStage, dstStage) = case side of+      Release -> (from.stage, if toHost then next.stage else Vk.PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT)+      Acquire -> (Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT, next.stage)+  case side of+    Release -> do+      when (owned || toHost) $ queueBufferBarrier rec srcStage dstStage barrier+      liftIO (writeIORef mb.releasedRef (Just cur))+    Acquire -> do+      -- An owned acquire without its armed release half would record an+      -- unmatched barrier from a guessed state: a schedule bug, not a+      -- recoverable condition.+      when (owned && isNothing released) $+        error+          ( "Vulkan.Utils.FrameGraph: ownership acquire of "+              <> show mb.info+              <> " without a pending release; the schedule must pair the halves"+          )+      when owned $ queueBufferBarrier rec srcStage dstStage barrier+      liftIO do+        -- The host is not a device queue: recording it as the last one would+        -- make the next device access look cross-queue (cf. 'nextTransition'),+        -- and the driver defers host passes — a late write here would rewind+        -- the device-side tracking.+        unless hosted do+          writeIORef mb.stateRef next+          writeIORef mb.queueRef (Just queue)+        -- Only the owned half consumed the hand-off; a melted acquire (host,+        -- shared, same family) must leave the slot for a pending owned one.+        when owned $ writeIORef mb.releasedRef Nothing+      markChained rec node++{- | Diff the tracked state against the 'Usage''s target and advance it.++A read whose state differs from the previous one still emits a barrier (the+chain through it is what orders a later write after both reads); only a read+of an already-matching state skips it.+-}+nextTransition+  :: (MonadIO m)+  => Accessor+  -> (FG.QueueId -> FG.QueueId -> Bool)+  -- ^ whether two queues belong to one family (share ownership)+  -> Bool+  -- ^ an ownership acquire already synchronized it ('chainedNode')+  -> ManagedBuffer+  -> Usage+  -> m (Maybe (Vk.PipelineStageFlags, Vk.PipelineStageFlags, SomeStruct Vk.BufferMemoryBarrier))+nextTransition accessor sameFamily marked mb usage = liftIO do+  cur <- readIORef mb.stateRef+  lastQueue <- readIORef mb.queueRef+  let+    next = usageState usage+    -- A first access owns nothing yet, and the host is not a queue family (its+    -- accesses order through the schedule's timeline and the producer's+    -- release barrier), so neither crosses ownership.+    crossQueue = case (accessor, lastQueue) of+      (DeviceQueue q, Just prev) -> q /= prev+      _ -> False+    crossFamily =+      crossQueue && case (accessor, lastQueue) of+        (DeviceQueue q, Just prev) -> not (sameFamily q prev)+        _ -> False+    -- A cross-queue hop rides the driver's semaphore even within one family.+    chained = crossQueue || marked+    srcStage = if chained then next.stage else cur.stage+    srcAccess = if chained then zero else cur.access+    -- Semaphore/event-ordered same-state accesses need no barrier of their+    -- own; unchained writes need one even with the state unchanged.+    needed = cur /= next || (usageWrites usage && not chained)+  -- An unshared (EXCLUSIVE) resource reaching another family without an+  -- ownership transfer ('transferOwnership') has undefined contents there. A+  -- write that does not read them is still fine — it acquires by discarding+  -- them — but a read would see garbage, so it is fatal.+  when (crossFamily && not mb.shared && not (usageWrites usage)) $+    error+      ( "Vulkan.Utils.FrameGraph: cross-family read of an unshared resource ("+          <> show mb.info+          <> ") the graph never handed over: it must be produced on the reading family, "+          <> "marked 'sharedAcrossQueues' (CONCURRENT), or written by a pass the graph "+          <> "can transfer ownership from"+      )+  case accessor of+    DeviceQueue q -> writeIORef mb.queueRef (Just q)+    HostAccess -> pure ()+  if needed+    then do+      writeIORef mb.stateRef next+      pure $+        Just+          ( srcStage+          , next.stage+          , SomeStruct+              zero+                { Vk.srcAccessMask = srcAccess+                , Vk.dstAccessMask = next.access+                , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+                , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+                , Vk.buffer = mb.buffer+                , Vk.offset = 0+                , Vk.size = Vk.WHOLE_SIZE+                }+          )+    else+      pure Nothing++{- | Descriptor for a 'ManagedBuffer'; carries the buffer's 'describedAs'+summary for visualization output (the resource name travels separately).+-}+newtype BufferDesc = BufferDesc {info :: Text}++{- | Import a 'ManagedBuffer' under @name@, as an observed resource.++Claims the graph's 'FG.addPreExec slot for 'flushBarriers' like the image+imports do — the adapters share that slot; wrap the flush rather than+replacing it.+-}+importManagedBuffer :: (MonadIO m) => FG.FrameGraph Recorder () -> Text -> ManagedBuffer -> m (FG.Handle ManagedBuffer)+importManagedBuffer graph name mb = do+  FG.addPreExec graph flushBarriers+  disarmHandOff mb+  FG.importResource graph name (BufferDesc mb.info) mb++-- | 'Vulkan.Utils.FrameGraph.Image.disarmHandOff' for the buffer lane.+disarmHandOff :: (MonadIO m) => ManagedBuffer -> m ()+disarmHandOff mb = liftIO (writeIORef mb.releasedRef Nothing)++-- | 'importManagedBuffer' via 'FG.importScratch', keeping writers subject to demand culling.+importScratchBuffer :: (MonadIO m) => FG.FrameGraph Recorder () -> Text -> ManagedBuffer -> m (FG.Handle ManagedBuffer)+importScratchBuffer graph name mb = do+  FG.addPreExec graph flushBarriers+  disarmHandOff mb+  FG.importScratch graph name (BufferDesc mb.info) mb++{- | The buffer counterpart of 'Vulkan.Utils.FrameGraph.Image.importOwnedImage':+'FG.importOwned' under the wrapper's tracked last queue, so a cross-family+first touch gets its release / acquire pair across the frame boundary.+-}+importOwnedBuffer :: (MonadIO m) => FG.FrameGraph Recorder () -> Text -> ManagedBuffer -> m (FG.Handle ManagedBuffer)+importOwnedBuffer graph name mb =+  liftIO (readIORef mb.queueRef) >>= \case+    Nothing -> importManagedBuffer graph name mb+    Just owner -> do+      FG.addPreExec graph flushBarriers+      disarmHandOff mb+      FG.importOwned graph name (BufferDesc mb.info) mb owner

@@ -0,0 +1,460 @@+{-# LANGUAGE DataKinds #-}++{-| Package-level multi-queue submit driver.++'submitGraphQueued' turns a compiled graph into one submit per executing+device queue: a one-time primary begun from each queue's pool, cross-queue+ordering realised with per-run timeline semaphores straight off the+schedule — each wait's value from 'FG.Wait' and its stage decoded from the+accesses it protects ('waitStage'), the same stages the resource adapters+chain their cross-queue barriers to.++The host is just another queue: passes assigned to the designated host+'FG.QueueId' execute on the CPU after the submits, each waiting its+schedule waits on the real timelines and signalling its own — so readbacks+and mapped uploads take part in the same dependency graph, with the+device-side transitions landing producer-side ('FG.preRelease') and the+host-side hooks tracking state without recording ('setRecorderHost').++Frame-level synchronization is the caller's and arrives as 'SubmitExtras':+swapchain acquire/present semaphores, frames-in-flight timelines, and any+cross-frame hazard on a resource the graphs share (a previous frame's+still-in-flight read is not a pass the compiler can see). Everything inside+one graph is derived; everything between graphs is an extra.++Synchronization is timeline semaphores and synchronization2, and nothing+else: submits go through @vkQueueSubmit2@, so a wait carries its value and+its stage in one 'SemaphoreSubmitInfo'. The schedule's split-barrier events+are deliberately not realised as @VkEvent@s — they only ever bought overlap,+and each access already places a self-sufficient barrier. Binary semaphores+survive only where WSI mandates them (acquire/present), as 'SubmitExtras'.++Cross-queue hand-offs of an @EXCLUSIVE@ resource are realised as queue-family+ownership transfers: the adapters' release and acquire hooks emit the matching+barrier pair, naming the families from this driver's 'QueueSlot's. A+@CONCURRENT@ resource ('sharedAcrossQueues') owns nothing and rides the+semaphore alone.++Each queue's pass stream is cut into segments at wait boundaries+('planSegments'), one submit per segment, so mid-stream cross-queue+dependencies — device ping-pong, device→host→device round trips — schedule+instead of deadlocking.+-}+module Vulkan.Utils.FrameGraph.Driver+  ( submitGraphQueued+  , SubmitConfig (..)+  , QueueSlot (..)+  , submitConfig+  , frameSubmitConfig+  , Submitted (..)+  , waitSubmitted+  , waitStage+  , accessScopes+  ) where++import Control.Monad (unless, void)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Resource (MonadResource)+import Data.Bits ((.&.), (.|.))+import Data.Coerce (coerce)+import Data.Foldable (foldl', for_, toList, traverse_)+import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef)+import Data.List (partition)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Traversable (for)+import Data.Vector qualified as V+import Data.Word (Word32, Word64)+import Type.Reflection (eqTypeRep, typeRep, type (:~~:) (HRefl))++import Fragr qualified as FG+import Vulkan.CStruct.Extends (SomeStruct (..))+import Vulkan.Core10 qualified as Vk+import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore (signalSemaphore, waitSemaphoresSafe)+import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as SemaphoreSignalInfo (SemaphoreSignalInfo (..))+import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as SemaphoreWaitInfo (SemaphoreWaitInfo (..))+import Vulkan.Core13.Enums.AccessFlags2 (AccessFlagBits2 (..), AccessFlags2)+import Vulkan.Core13.Enums.PipelineStageFlags2 (PipelineStageFlagBits2 (..), PipelineStageFlags2)+import Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 (SubmitInfo2 (..), queueSubmit2)+import Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 qualified as CommandBufferSubmitInfo (CommandBufferSubmitInfo (..))+import Vulkan.Core13.Promoted_From_VK_KHR_synchronization2 qualified as SemaphoreSubmitInfo (SemaphoreSubmitInfo (..))+import Vulkan.Utils.Frame (Frame (..), SubmitExtras (..), allocatePrimary, allocateTimelineSemaphore, frameSubmitExtras, noExtras)+import Vulkan.Utils.FrameGraph.Buffer qualified as Buffer+import Vulkan.Utils.FrameGraph.Image qualified as Image+import Vulkan.Utils.FrameGraph.Recorder (Recorder, clearChained, flushBarriers, newRecorder, setRecorder, setRecorderFamilies, setRecorderHost)+import Vulkan.Zero (zero)++{- | One queue's completion handle.++Its per-run timeline reaches @value@ once every pass submitted there has+executed. Feed into frames-in-flight bookkeeping, or block on it with+'waitSubmitted'.+-}+data Submitted = Submitted+  { queue :: FG.QueueId+  , semaphore :: Vk.Semaphore+  , value :: Word64+  }++{- | The device side of one 'FG.QueueId': where its passes submit, which+family owns their resources, and the pool their buffers come from.+-}+data QueueSlot = QueueSlot+  { queue :: Vk.Queue+  , family :: Word32+  -- ^ names the sides of an ownership transfer across it+  , pool :: Vk.CommandPool+  }++{- | How 'submitGraphQueued' maps a graph onto the device.++'submitConfig' fills everything but the queue table with inert defaults.++The queue table maps the graph's 'FG.QueueId's to real queues and the pools+to take this run's one-time command buffers from (reset the pool to reclaim+them, e.g. per frame in flight). @extras@ adds the frame-level waits and+signals — waits on the queue's first segment, signals on its last (ignored+for the host queue, which has no submit to splice into).+-}+data SubmitConfig = SubmitConfig+  { device :: Vk.Device+  , queues :: FG.QueueId -> QueueSlot+  , hostQueue :: Maybe FG.QueueId+  -- ^ the host queue: its passes execute on the CPU after the submits+  , extras :: FG.QueueId -> SubmitExtras+  , register :: [Submitted] -> IO ()+  {- ^ Called with every queue's completion once the graph is recorded and+  before anything is submitted:+  wire it to the frame's GPU-work list ('Vulkan.Utils.Frame.fGPUWork') and+  reclamation waits the whole graph with no hand-rolled sync — and no race+  when a submit fails midway, since a registered-but-never-signalled value+  degrades to the recycler's wait timeout instead of reclaiming under+  in-flight work.+  -}+  , deferHost :: Maybe (IO () -> IO ())+  {- ^ Hand the ordered host-pass tail to this runner (e.g. the frame's+  deferred work, executed on the recycle thread) instead of executing it+  before returning; the caller's thread then never blocks on the GPU.++  A deferred host pass must not gate a presented image: at+  @vkQueuePresentKHR@ time every signal the present wait depends on must+  already be submitted (VUID 03268), and the deferred signal is not.+  Meter/readback sinks are fine; a host pass feeding the swapchain chain+  must run inline.+  -}+  }++-- | A 'SubmitConfig' with no host queue, no extras, and no completion sink.+submitConfig :: Vk.Device -> (FG.QueueId -> QueueSlot) -> SubmitConfig+submitConfig device queues =+  SubmitConfig+    { device+    , queues+    , hostQueue = Nothing+    , extras = const noExtras+    , register = const (pure ())+    , deferHost = Nothing+    }++{- | A 'SubmitConfig' wired to the frame.++The canonical frame extras ('frameSubmitExtras') ride 'FG.defaultQueue',+completions register into 'fGPUWork' before anything submits, and the host+tail lands in 'fDeferredWork' — the frame's recycle thread runs it, so the+render thread never blocks on the GPU (mind 'deferHost''s presentation+caveat). Override 'extras' by wrapping the field (it is per-queue) rather+than replacing it.+-}+frameSubmitConfig :: Vk.Device -> Frame rr -> Word32 -> (FG.QueueId -> QueueSlot) -> SubmitConfig+frameSubmitConfig dev f imageIndex queues =+  (submitConfig dev queues)+    { extras = \q -> if q == FG.defaultQueue then frameSubmitExtras f imageIndex else noExtras+    , register = \submitted ->+        for_ submitted \s ->+          atomicModifyIORef' (fGPUWork f) (\jobs -> ((s.semaphore, s.value) : jobs, ()))+    , deferHost = Just (\hostTail -> modifyIORef' (fDeferredWork f) (hostTail :))+    }++{- | Record a compiled graph and submit it, one submit per segment, then+execute the host queue's passes.++The per-run timelines live in the current 'MonadResource' scope, so keep it+open until the returned 'Submitted' values are waited on.++A queue's passes are cut into segments at wait boundaries ('planSegments'),+so mid-stream cross-queue dependencies — device ping-pong,+device→host→device round trips — schedule instead of deadlocking; each+segment's waits hoist to its own front.++Passes on the designated host queue record nothing: after the device+submits go out, each runs on the calling thread (or the 'deferHost' runner)+— its schedule waits realised as a host timeline wait, its body as plain IO+(peek a readback mapping, write an upload one), its signal as+'signalSemaphore', which already-submitted device work may be waiting on.+The graph must have at least one device pass.+-}+submitGraphQueued+  :: (MonadResource m)+  => FG.FrameGraph Recorder ()+  -> SubmitConfig+  -> m [Submitted]+submitGraphQueued graph config = do+  let+    dev = config.device+    queueTable = config.queues+    hostQueue = config.hostQueue+    extras = config.extras+  snap <- FG.snapshot graph+  let+    syncs = mapMaybe (.sync) snap.passes+    (hostSyncs, deviceSyncs) = partition (\s -> Just s.queue == hostQueue) syncs+    (segments, routes) = planSegments deviceSyncs+  case syncs of+    [] -> pure []+    _ -> do+      segmentSlots <- for segments \seg -> do+        let slot = queueTable seg.queue+        cb <- allocatePrimary dev slot.pool+        pure (seg, slot.queue, cb)+      let deviceQids = ordNub [seg.queue | seg <- segments]+      timelines <-+        Map.fromList <$> for (deviceQids <> ordNub [s.queue | s <- hostSyncs]) \qid -> do+          (_, timeline) <- allocateTimelineSemaphore dev 0+          pure (qid, timeline)+      buffers <- case NE.nonEmpty [cb | (_, _, cb) <- segmentSlots] of+        Nothing -> error "submitGraphQueued: a host-only graph has nothing to submit"+        Just ne -> pure ne+      let+        timelineOf qid =+          Map.findWithDefault (error "submitGraphQueued: wait on a queue with no executing pass") qid timelines+        -- Indexed: 'cbFor' runs per pass, and the segment list is a list.+        slotsV = V.fromList segmentSlots+        cbFor pid = case Map.lookup pid routes of+          Just ix -> let (_, _, cb) = slotsV V.! ix in cb+          Nothing -> error "submitGraphQueued: pass outside the planned schedule"++      let+        deviceDone =+          [ Submitted{queue = qid, semaphore = timelineOf qid, value = v}+          | qid <- deviceQids+          , let v = maximum [seg.signal | seg <- segments, seg.queue == qid]+          ]+        hostDone =+          [ Submitted{queue = qid, semaphore = timelineOf qid, value = v}+          | qid <- ordNub [s.queue | s <- hostSyncs]+          , let v = maximum [s.signal | s <- hostSyncs, s.queue == qid]+          ]+        done = deviceDone <> hostDone++      recorder <- newRecorder (NE.head buffers)+      -- The families an ownership transfer names its two sides from; the host+      -- queue is not a family and owns nothing.+      setRecorderFamilies recorder \q ->+        if Just q == hostQueue then Vk.QUEUE_FAMILY_IGNORED else+          -- GHC 9.2 can't parse ".family" (special identifier)+          let QueueSlot{family} = queueTable q in family+      deferredRef <- liftIO (newIORef [])+      FG.addPreExec graph flushBarriers+      -- The release hooks queue producer-side barriers after the pass body.+      FG.addPostExec graph flushBarriers+      let backend =+            FG.QueueBackend+              { FG.beforePass = \psync ->+                  if Just psync.queue == hostQueue+                    then setRecorderHost recorder psync.queue+                    else do+                      setRecorder recorder psync.queue (cbFor psync.passId)+                      -- Only an ownership acquire chains a node ('markChained');+                      -- clear it, or a stale mark suppresses a later pass's barrier.+                      clearChained recorder+              , FG.afterPass = \_psync -> pure ()+              , FG.invoke = \psync body ->+                  if Just psync.queue == hostQueue+                    then modifyIORef' deferredRef ((psync, body) :)+                    else body+              , FG.completed = pure []+              }+      FG.executeQueued graph backend Nothing recorder ()+      traverse_ Vk.endCommandBuffer buffers++      -- Recorded, nothing submitted yet: registering here means a failure while+      -- recording never leaves the recycler waiting on timelines the unwinding+      -- scope destroys, while a submit failing midway still only costs it the+      -- wait timeout.+      liftIO (config.register done)++      let+        firstSeg = Map.fromListWith (\_ old -> old) [(seg.queue, ix) | (ix, (seg, _, _)) <- zip [0 :: Int ..] segmentSlots]+        lastSeg = Map.fromList [(seg.queue, ix) | (ix, (seg, _, _)) <- zip [0 ..] segmentSlots]+      liftIO $ for_ (zip [0 ..] segmentSlots) \(ix, (seg, vkQueue, cb)) -> do+        let+          ex = extras seg.queue+          derived = [(timelineOf p, stages, value) | (p, (value, stages)) <- Map.toAscList seg.fronts]+          submitWaits = derived <> (if Map.lookup seg.queue firstSeg == Just ix then ex.waits else [])+          submitSignals =+            (timelineOf seg.queue, seg.signal)+              : (if Map.lookup seg.queue lastSeg == Just ix then ex.signals else [])+          -- A binary semaphore (the WSI pair) ignores the value; a timeline+          -- ignores nothing, and carries its stage in the same struct.+          waitInfo (sem, st, v) = zero{SemaphoreSubmitInfo.semaphore = sem, SemaphoreSubmitInfo.stageMask = st, SemaphoreSubmitInfo.value = v}+          signalInfo (sem, v) = zero{SemaphoreSubmitInfo.semaphore = sem, SemaphoreSubmitInfo.stageMask = PIPELINE_STAGE_2_ALL_COMMANDS_BIT, SemaphoreSubmitInfo.value = v}+          submit =+            zero+              { waitSemaphoreInfos = V.fromList (map waitInfo submitWaits)+              , commandBufferInfos = [SomeStruct zero{CommandBufferSubmitInfo.commandBuffer = Vk.commandBufferHandle cb}]+              , signalSemaphoreInfos = V.fromList (map signalInfo submitSignals)+              }+              :: SubmitInfo2 '[]+        queueSubmit2 vkQueue [SomeStruct submit] Vk.NULL_HANDLE++      -- The host passes, in schedule order: wait, run, signal — inline, or+      -- handed whole to the 'deferHost' runner.+      liftIO do+        deferred <- reverse <$> readIORef deferredRef+        let hostTail = for_ deferred \(psync, body) -> do+              unless (null psync.waits) $+                void $+                  waitSemaphoresSafe+                    dev+                    zero+                      { SemaphoreWaitInfo.semaphores = V.fromList [timelineOf w.queue | w <- psync.waits]+                      , SemaphoreWaitInfo.values = V.fromList [w.value | w <- psync.waits]+                      }+                    maxBound+              body+              signalSemaphore dev zero{SemaphoreSignalInfo.semaphore = timelineOf psync.queue, SemaphoreSignalInfo.value = psync.signal}+        case config.deferHost of+          Nothing -> hostTail+          Just runner -> unless (null deferred) (runner hostTail)+      pure done++{- | One planned submit: a contiguous run of one queue's passes whose+cross-queue waits all hoist to its front.+-}+data SegmentPlan = SegmentPlan+  { queue :: FG.QueueId+  , fronts :: Map FG.QueueId (Word64, PipelineStageFlags2)+  {- ^ per producer queue: the timeline value to wait for, at the covered+  accesses' stages+  -}+  , signal :: Word64+  -- ^ the value the segment's submit signals (its passes' max)+  }++{- | Cut each queue's pass stream into segments at wait boundaries.++A pass joins its queue's open segment when every wait it carries is already+implied by the segment's front (same producer, value not above the front's;+its stages widen the mask). Anything else — a higher value, a producer the+segment has not waited on — closes the segment and opens a new one fronted+by the pass's own waits. Front waits therefore only reference passes+registered before the segment's first pass, which makes the segment graph+acyclic by construction: no cycle check, no rejected schedules.++Waiting a mid-segment value completes when that segment's submit does — a+timeline wait is @>=@, so coarsening the signal points is sound.+-}+planSegments :: [FG.PassSync] -> ([SegmentPlan], Map Int Int)+planSegments syncs = (toList segs, routes)+  where+    (_, segs, routes) = foldl' step (Map.empty, Seq.empty, Map.empty) syncs+    step+      :: (Map FG.QueueId Int, Seq.Seq SegmentPlan, Map Int Int)+      -> FG.PassSync+      -> (Map FG.QueueId Int, Seq.Seq SegmentPlan, Map Int Int)+    step (open, acc, rts) s =+      let+        -- An acquire barrier is only ordered after its release if the wait's dst+        -- scope covers it, and its src half comes from the pre-release state —+        -- a stage the consuming accesses need not name. Widen, or the two halves+        -- of the transition race (WAW on the layout transition).+        acquiring = if null s.acquires then zero else PIPELINE_STAGE_2_ALL_COMMANDS_BIT+        needs = Map.fromListWith mergeWait [(w.queue, (w.value, waitStage w .|. acquiring)) | w <- s.waits]+        covered seg =+          Map.foldrWithKey+            (\p (v, _) ok -> ok && maybe False ((v <=) . fst) (Map.lookup p seg.fronts))+            True+            needs+      in+        case Map.lookup s.queue open of+          Just ix+            | seg <- Seq.index acc ix+            , covered seg ->+                ( open+                , Seq.adjust+                    (\sg -> SegmentPlan{queue = sg.queue, fronts = Map.unionWith mergeWait sg.fronts needs, signal = max sg.signal s.signal})+                    ix+                    acc+                , Map.insert s.passId ix rts+                )+          _ ->+            let ix = Seq.length acc+            in ( Map.insert s.queue ix open+               , acc Seq.|> SegmentPlan{queue = s.queue, fronts = needs, signal = s.signal}+               , Map.insert s.passId ix rts+               )+    mergeWait (v1, st1) (v2, st2) = (max v1 v2, st1 .|. st2)++-- | Order-preserving dedup for the short queue lists.+ordNub :: (Ord a) => [a] -> [a]+ordNub = go Set.empty+  where+    go _ [] = []+    go seen (x : xs)+      | x `Set.member` seen = go seen xs+      | otherwise = x : go (Set.insert x seen) xs++-- | Block until every 'Submitted' timeline reaches its value.+waitSubmitted :: (MonadIO m) => Vk.Device -> Word64 -> [Submitted] -> m Vk.Result+waitSubmitted _ _ [] = pure Vk.SUCCESS+waitSubmitted dev timeout submitted =+  waitSemaphoresSafe+    dev+    zero+      { SemaphoreWaitInfo.semaphores = V.fromList [s.semaphore | s <- submitted]+      , SemaphoreWaitInfo.values = V.fromList [s.value | s <- submitted]+      }+    timeout++{- | The stage a schedule wait is consumed at ('SemaphoreSubmitInfo.stageMask').++The OR of its protected accesses' stages. Matches the adapters' cross-queue+barrier chaining ('Image.queueTransition' hands over at exactly the+consuming usage's stage), so the semaphore and the barrier meet. An access+declared without flags carries no scope: over-synchronize.+-}+waitStage :: FG.Wait -> PipelineStageFlags2+waitStage w+  | null w.covers = PIPELINE_STAGE_2_ALL_COMMANDS_BIT+  | otherwise = foldl' (\acc a -> acc .|. fst (accessScopes a)) zero w.covers++{- | An access's synchronization2 scope (stage + access mask).++Dispatched on the access's resource type; an adapter this module does not+know about carries no decodable scope and over-synchronizes.+-}+accessScopes :: FG.Access -> (PipelineStageFlags2, AccessFlags2)+accessScopes (FG.Access (_ :: FG.Handle r) flags) = case flags of+  Nothing -> fullScope+  Just f+    | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Image.ManagedImage) ->+        fromState (Image.usageState f).stage (Image.usageState f).access+    | Just HRefl <- eqTypeRep (typeRep @r) (typeRep @Buffer.ManagedBuffer) ->+        fromState (Buffer.usageState f).stage (Buffer.usageState f).access+    | otherwise -> fullScope+  where+    fullScope = (PIPELINE_STAGE_2_ALL_COMMANDS_BIT, ACCESS_2_MEMORY_READ_BIT .|. ACCESS_2_MEMORY_WRITE_BIT)+    fromState st ac+      | st == zero || st .&. Vk.PIPELINE_STAGE_HOST_BIT /= zero = fullScope+      | otherwise = (stage2 st, access2 ac)++-- The synchronization1 bits are valid synchronization2 bits verbatim.+stage2 :: Vk.PipelineStageFlags -> PipelineStageFlags2+stage2 s = coerce (fromIntegral (coerce s :: Word32) :: Word64)++access2 :: Vk.AccessFlags -> AccessFlags2+access2 a = coerce (fromIntegral (coerce a :: Word32) :: Word64)

@@ -0,0 +1,680 @@+{-| A 'FG.Resource' for Vulkan images that places layout-transition barriers+automatically.++A 'ManagedImage' carries the image plus its tracked 'ImageState' (layout,+stage, access). A pass declares an access with a 'Usage' (the instance's+'FG.Flags' type); the 'FG.preRead' / 'FG.preWrite' hooks diff the+tracked state against the usage's target and queue the barrier into the+'Recorder''s per-pass batch, one @vkCmdPipelineBarrier@ per pass — the+'transitionImageTo' rules, plus semaphore chaining when the access hops+queues.++Import-only: the graph tracks the layout and places barriers but does not own+the allocation (see the package README).+-}+module Vulkan.Utils.FrameGraph.Image+  ( ManagedImage (..)+  , newManagedImage+  , newManagedImageMip+  , newManagedImageLayer+  , newManagedImageSlice+  , SliceRegistry+  , newSliceRegistry+  , forgetImage+  , claimOwnership+  , ImageDesc (..)+  , importManagedImage+  , importScratchImage+  , importOwnedImage+  , describedAs+  , sharedAcrossQueues+  , imageInfo+  , describedImage+  , describedMip+  , describedSlice+  , ImageState (..)+  , undefinedState+  , Usage (..)+  , usageState+  , transitionImageTo+  , transitionImagesTo+  , queueTransition+  , transferOwnership+  , sliceLayers+  , copyManagedImageToHost+  ) where++import Control.Monad (filterM, foldM, unless, when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Bits ((.&.), (.|.))+import Data.Foldable (traverse_)+import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, writeIORef)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as V+import Data.Word (Word32)+import GHC.Stack (HasCallStack)+import System.Mem (performGC)+import System.Mem.Weak (Weak, deRefWeak)++import Fragr qualified as FG+import Vulkan.CStruct.Extends (SomeStruct (..))+import Vulkan.Core10 qualified as Vk+import Vulkan.Utils.FrameGraph.Recorder (Accessor (..), Recorder, TransferSide (..), chainedNode, flushBarriers, markChained, overlappingRanges, queueBarrier, recorderFamily, recorderHost, recorderQueue, recorderSameFamily)+import Vulkan.Zero (zero)++{- | An image, or an arbitrary @(mip × array-layer)@ slice of it, whose+layout/stage/access the frame graph tracks and transitions.++The @range@ is the barrier's subresource range, so any slicing granularity is one+'ManagedImage' per slice over the same 'Vk.Image', each tracked independently — the+intra-image barriers fall out of that. A whole-image wrapper ('newManagedImage')+covers all mips+layers as one unit (e.g. a multiview render); per-mip+('newManagedImageMip', a bloom pyramid) or per-layer ('newManagedImageLayer', a+cubemap face / array element) wrappers give finer control. Slices tracked+separately must not overlap — wrapping checks that against the image's live+wrappers in the renderer's 'SliceRegistry' and fails fast, since two trackers+over one subresource diverge silently (wrong old layouts, missed barriers).+-}+data ManagedImage = ManagedImage+  { image :: Vk.Image+  , range :: Vk.ImageSubresourceRange+  , stateRef :: IORef ImageState+  , queueRef :: IORef (Maybe FG.QueueId)+  -- ^ The device queue that last accessed it; 'Nothing' until one has.+  , releasedRef :: IORef (Maybe ImageState)+  {- ^ The state a pending ownership release saw, so the acquiring half can+  build the barrier that matches it exactly.+  -}+  , shared :: Bool+  {- ^ The allocation is @SHARING_MODE_CONCURRENT@ across the families the+  graph uses it on ('sharedAcrossQueues'). An unmarked resource accessed+  across queues is fatal: no ownership transfer is emitted, so its contents+  would be undefined on the new family.+  -}+  , info :: Text+  {- ^ Human-readable summary (format/extent, see 'imageInfo') shown by+  visualization output; attach with 'describedAs'.+  -}+  }++-- | Wrap a whole image (all mips + layers, monolithic), starting from 'undefinedState'.+newManagedImage :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Image -> Vk.ImageAspectFlags -> m ManagedImage+{-# INLINE newManagedImage #-}+newManagedImage reg image aspect = newManaged reg image (Vk.ImageSubresourceRange aspect 0 Vk.REMAINING_MIP_LEVELS 0 Vk.REMAINING_ARRAY_LAYERS)++-- | Wrap a single mip level (all its layers), tracked independently of the others.+newManagedImageMip :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Image -> Vk.ImageAspectFlags -> Word32 -> m ManagedImage+{-# INLINE newManagedImageMip #-}+newManagedImageMip reg image aspect mip = newManaged reg image (Vk.ImageSubresourceRange aspect mip 1 0 1)++-- | Wrap a single array layer / cubemap face (mip 0), tracked independently.+newManagedImageLayer :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Image -> Vk.ImageAspectFlags -> Word32 -> m ManagedImage+{-# INLINE newManagedImageLayer #-}+newManagedImageLayer reg image aspect layer = newManaged reg image (Vk.ImageSubresourceRange aspect 0 1 layer 1)++-- | Wrap an arbitrary @(mip × layer)@ slice (e.g. one light's 6 cube faces in an array).+newManagedImageSlice :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Image -> Vk.ImageAspectFlags -> Word32 -> Word32 -> Word32 -> Word32 -> m ManagedImage+{-# INLINE newManagedImageSlice #-}+newManagedImageSlice reg image aspect baseMip levelCount baseLayer layerCount =+  newManaged reg image (Vk.ImageSubresourceRange aspect baseMip levelCount baseLayer layerCount)++newManaged :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Image -> Vk.ImageSubresourceRange -> m ManagedImage+{-# INLINE newManaged #-}+newManaged reg image range = liftIO do+  stateRef <- newIORef undefinedState+  registerSlice reg image range stateRef+  queueRef <- newIORef Nothing+  releasedRef <- newIORef Nothing+  pure ManagedImage{releasedRef, image, range, stateRef, queueRef, shared = False, info = ""}++{- | A registry of live wrappers per image, enforcing the non-overlap+contract at wrap time ('registerSlice').++One per renderer, created where the images' owning scope begins (the+@ResourceT@ the render loop runs in): replacing the renderer replaces the+registry, so a dead scope's wrappers cannot poison the next one's over the+persisting Vulkan context.+-}+newtype SliceRegistry = SliceRegistry (IORef (Map Vk.Image [SliceEntry]))++-- | One live wrapper's range in a 'SliceRegistry' bucket.+data SliceEntry = SliceEntry+  { range :: Vk.ImageSubresourceRange+  , weak :: Weak (IORef ImageState)+  }++newSliceRegistry :: (MonadIO m) => m SliceRegistry+newSliceRegistry = liftIO (SliceRegistry <$> newIORef Map.empty)++{- | Check the range against the image's live wrappers and record it, fatally+on overlap.++Entries are weak, keyed on each wrapper's 'stateRef': a dropped wrapper's+tracker can never diverge again, so its range frees on collection. That also+keeps a recycled 'Vk.Image' handle (destroy, then create getting the same+value) from clashing with the destroyed image's wrappers.+-}+registerSlice :: (HasCallStack) => SliceRegistry -> Vk.Image -> Vk.ImageSubresourceRange -> IORef ImageState -> IO ()+registerSlice (SliceRegistry registry) image range stateRef = do+  live0 <- pruneLive+  -- A clash may be a dropped wrapper the GC has not reached yet: collect+  -- before accusing.+  live <- if any clash live0 then performGC *> pruneLive else pure live0+  case filter clash live of+    [] -> pure ()+    clashes ->+      error+        ( "Vulkan.Utils.FrameGraph: wrapping "+            <> show range+            <> " of "+            <> show image+            <> " overlaps a live ManagedImage over "+            <> show (map (.range) clashes)+            <> "; slices tracked separately must not overlap"+        )+  -- No finalizer: dead entries are pruned on the image's next wrap (or by+  -- 'forgetImage'), keeping this insert the map's only writer — a finalizer+  -- racing it could resurrect the entry it just removed.+  weak <- mkWeakIORef stateRef (pure ())+  atomicModifyIORef' registry \m -> (Map.insert image (SliceEntry{range, weak} : live) m, ())+  where+    clash e = overlappingRanges range e.range+    pruneLive = do+      m <- readIORef registry+      filterM (fmap isJust . deRefWeak . (.weak)) (Map.findWithDefault [] image m)++{- | Drop every wrapper registered over the image, reachable or not.++The deterministic half of deregistration: weak entries only free once+nothing holds the wrapper, but a destroyed image's wrappers may stay+reachable through scopes that outlive it (another in-flight frame's slot).+Register this next to the image's destruction so a recycled handle cannot+clash with them.+-}+forgetImage :: (MonadIO m) => SliceRegistry -> Vk.Image -> m ()+forgetImage (SliceRegistry registry) image =+  liftIO (atomicModifyIORef' registry \m -> (Map.delete image m, ()))++{- | Attach a summary (e.g. 'imageInfo') shown next to the resource's name+in visualization output.+-}+describedAs :: Text -> ManagedImage -> ManagedImage+describedAs t ManagedImage{..} = ManagedImage{info = t, ..}++{- | Mark the allocation as @SHARING_MODE_CONCURRENT@ across the families it+is used on.++Required before any cross-family access the graph cannot transfer+ownership for: an @EXCLUSIVE@ image's contents are undefined on the new+family, so crossing without this is fatal, not silent. Apply before+importing — imports read it through 'FG.isShared', exempting the image+from the schedule's single-owner validation.+-}+sharedAcrossQueues :: ManagedImage -> ManagedImage+sharedAcrossQueues mi = mi{shared = True}++-- | The conventional 'describedAs' summary: the format (sans prefix) and extent.+imageInfo :: Vk.Format -> Vk.Extent2D -> Text+imageInfo format (Vk.Extent2D w h) =+  Text.pack (drop (Text.length "FORMAT_") (show format) <> " " <> show w <> "x" <> show h)++{- | 'newManagedImage' with the 'imageInfo' description attached, stating the+allocation's format/extent once.+-}+describedImage :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Format -> Vk.Extent2D -> Vk.Image -> Vk.ImageAspectFlags -> m ManagedImage+describedImage reg format ext image aspect = describedAs (imageInfo format ext) <$> newManagedImage reg image aspect++-- | 'newManagedImageMip' with the mip's 'imageInfo' description attached.+describedMip :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Format -> Vk.Extent2D -> Vk.Image -> Vk.ImageAspectFlags -> Word32 -> m ManagedImage+describedMip reg format ext image aspect mip = describedAs (imageInfo format ext) <$> newManagedImageMip reg image aspect mip++-- | A mip-0 layer range via 'newManagedImageSlice', with the 'imageInfo' description attached.+describedSlice :: (HasCallStack, MonadIO m) => SliceRegistry -> Vk.Format -> Vk.Extent2D -> Vk.Image -> Vk.ImageAspectFlags -> Word32 -> Word32 -> m ManagedImage+describedSlice reg format ext image aspect baseLayer layerCount = describedAs (imageInfo format ext) <$> newManagedImageSlice reg image aspect 0 1 baseLayer layerCount++instance FG.Resource ManagedImage where+  type Desc ManagedImage = ImageDesc+  type Alloc ManagedImage = ()+  type Ctx ManagedImage = Recorder+  type Flags ManagedImage = Usage++  createResource _ _ =+    error "ManagedImage is import-only: allocate the image and use importResource"++  destroyResource _ _ _ = pure ()++  preRead h _ usage rec mi = queueTransition rec (FG.handleId h) mi usage+  preWrite h _ usage rec mi = queueTransition rec (FG.handleId h) mi usage++  -- The two halves of a cross-queue hand-off, fired on the producing and the+  -- consuming side of each data edge.+  preRelease h _ usage peer rec mi = transferOwnership Release rec (FG.handleId h) peer mi usage+  preAcquire h _ usage peer rec mi = transferOwnership Acquire rec (FG.handleId h) peer mi usage++  isShared mi = mi.shared++  describeDesc d = d.info++-- | The synchronization state an image is currently left in.+data ImageState = ImageState+  { layout :: Vk.ImageLayout+  , stage :: Vk.PipelineStageFlags+  , access :: Vk.AccessFlags+  }+  deriving stock (Eq, Show)++-- | Freshly created / never-transitioned: undefined layout, top of pipe.+undefinedState :: ImageState+undefinedState =+  ImageState+    { layout = Vk.IMAGE_LAYOUT_UNDEFINED+    , stage = Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT+    , access = zero+    }++{- | How a pass uses an image, i.e. the 'ImageState' it must be in for that+access. The per-access payload of 'FG.readWith' / 'FG.writeWith'.+-}+data Usage+  = ColorAttachment+  | DepthAttachment+  | TransferSrc+  | TransferDst+  | Present+  | -- | Storage read/write in the given shader stage (compute, fragment, …).+    StorageRead Vk.PipelineStageFlags+  | StorageWrite Vk.PipelineStageFlags+  | -- | Sampled in the given shader stage (fragment, compute, …).+    Sampled Vk.PipelineStageFlags+  | -- | Read by the host after a fence (@GENERAL@, the layout mapped linear images live in).+    HostRead+  deriving stock (Eq, Ord, Show)++{- | The target state each 'Usage' requires. Stage/access mirror the+@Vulkan.Utils.Barrier@ @transition*@ helpers.+-}+usageState :: Usage -> ImageState+usageState = \case+  -- READ covers @LOAD_OP_LOAD@ and blending, as DepthAttachment's covers the depth test.+  ColorAttachment ->+    ImageState+      Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL+      Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT+      (Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT)+  DepthAttachment ->+    ImageState+      Vk.IMAGE_LAYOUT_DEPTH_ATTACHMENT_OPTIMAL+      (Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT .|. Vk.PIPELINE_STAGE_LATE_FRAGMENT_TESTS_BIT)+      (Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_READ_BIT .|. Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT)+  TransferSrc ->+    ImageState+      Vk.IMAGE_LAYOUT_TRANSFER_SRC_OPTIMAL+      Vk.PIPELINE_STAGE_TRANSFER_BIT+      Vk.ACCESS_TRANSFER_READ_BIT+  TransferDst ->+    ImageState+      Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+      Vk.PIPELINE_STAGE_TRANSFER_BIT+      Vk.ACCESS_TRANSFER_WRITE_BIT+  Present ->+    ImageState+      Vk.IMAGE_LAYOUT_PRESENT_SRC_KHR+      Vk.PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT+      zero+  StorageRead stage ->+    ImageState Vk.IMAGE_LAYOUT_GENERAL stage Vk.ACCESS_SHADER_READ_BIT+  StorageWrite stage ->+    ImageState Vk.IMAGE_LAYOUT_GENERAL stage Vk.ACCESS_SHADER_WRITE_BIT+  Sampled stage ->+    ImageState Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL stage Vk.ACCESS_SHADER_READ_BIT+  HostRead ->+    ImageState Vk.IMAGE_LAYOUT_GENERAL Vk.PIPELINE_STAGE_HOST_BIT Vk.ACCESS_HOST_READ_BIT++{- | Whether the 'Usage' writes the image (and so needs a barrier even when the+state is unchanged — only read-after-read can skip it).+-}+usageWrites :: Usage -> Bool+usageWrites = \case+  ColorAttachment -> True+  DepthAttachment -> True+  TransferDst -> True+  StorageWrite _ -> True+  TransferSrc -> False+  Present -> False+  StorageRead _ -> False+  Sampled _ -> False+  HostRead -> False++{- | Record the barrier bringing the image into the 'Usage''s state and update+the tracked state. Standalone counterpart to the hook path, for barriers+recorded outside a pass; treats the access as same-queue.++A write 'Usage' records the barrier even when the state is unchanged — a+same-state write still needs the execution+memory dependency against the+previous access. Only a read of an already-matching state skips it.+-}+transitionImageTo :: (MonadIO m) => Vk.CommandBuffer -> ManagedImage -> Usage -> m ()+{-# INLINE transitionImageTo #-}+transitionImageTo cb mi usage = transitionImagesTo cb [(mi, usage)]++{- | 'transitionImageTo' over a batch: one @vkCmdPipelineBarrier@, OR-ed stage masks.++The images must be tracked separately (distinct non-overlapping slices):+barriers in one command are unordered, so two entries for the same slice+would race.+-}+transitionImagesTo :: (MonadIO m) => Vk.CommandBuffer -> [(ManagedImage, Usage)] -> m ()+transitionImagesTo cb accesses = do+  (srcs, dsts, barriers) <- foldM collect (zero, zero, []) accesses+  unless (null barriers) $+    Vk.cmdPipelineBarrier cb srcs dsts zero [] [] (V.fromList barriers)+  where+    collect acc@(srcs, dsts, barriers) (mi, usage) = do+      lastQueue <- liftIO (readIORef mi.queueRef)+      nextTransition (maybe HostAccess DeviceQueue lastQueue) (\_ _ -> True) False mi usage >>= \case+        Nothing -> pure acc+        Just (src, dst, barrier) -> pure (srcs .|. src, dsts .|. dst, barrier : barriers)++{- | Copy an image into a host-readable one via the trackers.++The source moves to @TRANSFER_SRC@ from whatever state it is actually in, the+destination through @TRANSFER_DST@ to 'HostRead' — no assumed layouts, no+hand-rolled host barrier. Copies the first mip and layer of each wrapper's+slice (the aspects must match).+-}+copyManagedImageToHost :: (MonadIO m) => Vk.CommandBuffer -> Vk.Extent2D -> ManagedImage -> ManagedImage -> m ()+copyManagedImageToHost cb (Vk.Extent2D w h) src cpu = do+  transitionImagesTo cb [(src, TransferSrc), (cpu, TransferDst)]+  Vk.cmdCopyImage+    cb+    src.image+    (usageState TransferSrc).layout+    cpu.image+    (usageState TransferDst).layout+    [Vk.ImageCopy (sliceLayers src) (Vk.Offset3D 0 0 0) (sliceLayers cpu) (Vk.Offset3D 0 0 0) (Vk.Extent3D w h 1)]+  transitionImageTo cb cpu HostRead++-- | The slice's first mip and layer, as a transfer command's subresource.+sliceLayers :: ManagedImage -> Vk.ImageSubresourceLayers+sliceLayers mi = Vk.ImageSubresourceLayers mi.range.aspectMask mi.range.baseMipLevel mi.range.baseArrayLayer 1++{- | The hook path: 'transitionImageTo' rules, but queued and queue-aware.++The barrier goes into the 'Recorder''s per-pass batch (flushed before the+exec callback), and when the access rides a prior synchronization — a+cross-queue hop (the driver's semaphore) or a split-barrier event the pass+waited on ('chainedNode') — it chains to it instead: source scope becomes+the destination stage with no access mask, since the semaphore/event+already provides execution ordering and memory availability. The driver's+wait @dstStageMask@ / event scope must cover the usage's stage (both then+chain). Same-family queues share freely; crossing to another /family/+needs CONCURRENT sharing or an ownership acquire this pass performed —+otherwise an EXCLUSIVE image's contents are undefined there.+-}+queueTransition :: (MonadIO m) => Recorder -> Int -> ManagedImage -> Usage -> m ()+queueTransition rec node mi usage = do+  queue <- recorderQueue rec+  chained0 <- chainedNode rec node+  hosted <- recorderHost rec+  sameFamily <- recorderSameFamily rec+  nextTransition (if hosted then HostAccess else DeviceQueue queue) sameFamily chained0 mi usage >>= traverse_ \(srcStage, dstStage, barrier) ->+    queueBarrier rec srcStage dstStage barrier++{- | The producer- and consumer-side halves of a cross-queue hand-off.++On a @CONCURRENT@ image ('sharedAcrossQueues') the release half carries the+layout transition producer-side — its source scope stays on a queue that+supports it — and the acquire half is a no-op: the driver's semaphore+already orders the two, and no family owns the image.++On an @EXCLUSIVE@ image the pair is a real queue-family ownership transfer:+the same barrier is recorded twice, once in each queue's buffer, with both+family indices named. The halves must match exactly, so both are computed+from the state the release saw — the acquire is what advances the tracked+state, and it marks the node chained so the consumer's own declared access+does not place a second barrier on top of it.++Same-family queues own nothing to transfer: the release still moves the+layout, the acquire still just advances the tracking.++A hand-off to the host is neither: the release carries the full dependency+(a semaphore signal makes device writes available to the device domain+only, so the host half needs a real @HOST@ destination scope), and the+acquire is bookkeeping.+-}+transferOwnership :: (MonadIO m) => TransferSide -> Recorder -> Int -> FG.QueueId -> ManagedImage -> Usage -> m ()+transferOwnership side rec node peer mi usage = do+  hosted <- recorderHost rec+  queue <- recorderQueue rec+  ourFamily <- recorderFamily rec queue+  peerFamily <- recorderFamily rec peer+  cur <- liftIO (readIORef mi.stateRef)+  released <- liftIO (readIORef mi.releasedRef)+  let+    next = usageState usage+    -- The producer is the release's queue and the acquire's peer.+    (srcFamily, dstFamily) = case side of+      Release -> (ourFamily, peerFamily)+      Acquire -> (peerFamily, ourFamily)+    -- The host owns nothing (it is not a family), and a CONCURRENT image is+    -- owned by no one: those hand-offs ride the semaphore alone.+    owned =+      not mi.shared+        && not hosted+        && srcFamily /= dstFamily+        && srcFamily /= Vk.QUEUE_FAMILY_IGNORED+        && dstFamily /= Vk.QUEUE_FAMILY_IGNORED+    -- The consumer is the host: only the release's barrier can make the+    -- device's writes visible to it (the schedule's timeline wait cannot).+    toHost = next.stage .&. Vk.PIPELINE_STAGE_HOST_BIT /= zero+    -- Both halves describe the same barrier, so the acquire builds its own+    -- from the state the release saw.+    from = case side of+      Release -> cur+      Acquire -> fromMaybe cur released+    barrier =+      SomeStruct+        zero+          { Vk.srcAccessMask = case side of+              Release -> from.access+              Acquire -> zero+          , Vk.dstAccessMask = case side of+              Release -> if toHost then next.access else zero+              Acquire -> next.access+          , Vk.oldLayout = from.layout+          , Vk.newLayout = next.layout+          , Vk.srcQueueFamilyIndex = if owned then srcFamily else Vk.QUEUE_FAMILY_IGNORED+          , Vk.dstQueueFamilyIndex = if owned then dstFamily else Vk.QUEUE_FAMILY_IGNORED+          , Vk.image = mi.image+          , Vk.subresourceRange = mi.range+          }+    -- A release's destination scope and an acquire's source scope are ignored+    -- by the spec; the halves must otherwise be identical.+    (srcStage, dstStage) = case side of+      Release -> (from.stage, if toHost then next.stage else Vk.PIPELINE_STAGE_BOTTOM_OF_PIPE_BIT)+      Acquire -> (Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT, next.stage)+  case side of+    Release -> do+      -- The release performs the layout transition (its barrier executes on+      -- the producer's queue), so the tracked state advances with it.+      when (owned || toHost || cur /= next) do+        queueBarrier rec srcStage dstStage barrier+        liftIO (writeIORef mi.stateRef next)+      liftIO (writeIORef mi.releasedRef (Just cur))+    Acquire -> do+      -- An owned acquire without its armed release half would record an+      -- unmatched barrier from a guessed state: a schedule bug, not a+      -- recoverable condition.+      when (owned && isNothing released) $+        error+          ( "Vulkan.Utils.FrameGraph: ownership acquire of "+              <> show mi.info+              <> " without a pending release; the schedule must pair the halves"+          )+      when owned $ queueBarrier rec srcStage dstStage barrier+      liftIO do+        -- The host is not a device queue: recording it as the last one would+        -- make the next device access look cross-queue (cf. 'nextTransition'),+        -- and its release already advanced the state (the @toHost@ arm) — the+        -- driver defers host passes, so a late write here would rewind the+        -- device-side tracking.+        unless hosted do+          writeIORef mi.stateRef next+          writeIORef mi.queueRef (Just queue)+        -- Only the owned half consumed the hand-off; a melted acquire (host,+        -- shared, same family) must leave the slot for a pending owned one.+        when owned $ writeIORef mi.releasedRef Nothing+      markChained rec node++{- | Diff the tracked state against the 'Usage''s target and advance it.++Hands back the @(srcStage, dstStage, barrier)@ still to be recorded — the+caller commits to recording it (immediately or batched) before the access+runs.+-}+nextTransition+  :: (MonadIO m)+  => Accessor+  -> (FG.QueueId -> FG.QueueId -> Bool)+  -- ^ whether two queues belong to one family (share ownership)+  -> Bool+  -- ^ an ownership acquire already synchronized it ('chainedNode')+  -> ManagedImage+  -> Usage+  -> m (Maybe (Vk.PipelineStageFlags, Vk.PipelineStageFlags, SomeStruct Vk.ImageMemoryBarrier))+nextTransition accessor sameFamily marked mi usage = liftIO do+  cur <- readIORef mi.stateRef+  lastQueue <- readIORef mi.queueRef+  let+    next = usageState usage+    -- A first access owns nothing yet, and the host is not a queue family (its+    -- accesses order through the schedule's timeline and the producer's+    -- release barrier), so neither crosses ownership.+    crossQueue = case (accessor, lastQueue) of+      (DeviceQueue q, Just prev) -> q /= prev+      _ -> False+    crossFamily =+      crossQueue && case (accessor, lastQueue) of+        (DeviceQueue q, Just prev) -> not (sameFamily q prev)+        _ -> False+    -- A cross-queue hop rides the driver's semaphore even within one family.+    chained = crossQueue || marked+    -- Crossing to a new family without a transfer: the contents are undefined+    -- there, so the access acquires by discarding them (it writes — the guard+    -- below rejects a read).+    discards = crossFamily && not mi.shared+    srcStage = if chained then next.stage else cur.stage+    srcAccess = if chained then zero else cur.access+    -- Semaphore/event-ordered same-state accesses need no barrier of their+    -- own; unchained writes need one even with the state unchanged.+    needed = cur /= next || (usageWrites usage && not chained)+  -- An unshared (EXCLUSIVE) resource reaching another family without an+  -- ownership transfer ('transferOwnership') has undefined contents there. A+  -- write that does not read them is still fine — it acquires by discarding+  -- (see 'discards') — but a read would see garbage, so it is fatal.+  when (crossFamily && not mi.shared && not (usageWrites usage)) $+    error+      ( "Vulkan.Utils.FrameGraph: cross-family read of an unshared resource ("+          <> show mi.info+          <> ") the graph never handed over: it must be produced on the reading family, "+          <> "marked 'sharedAcrossQueues' (CONCURRENT), or written by a pass the graph "+          <> "can transfer ownership from"+      )+  case accessor of+    DeviceQueue q -> writeIORef mi.queueRef (Just q)+    HostAccess -> pure ()+  if needed+    then do+      writeIORef mi.stateRef next+      pure $+        Just+          ( srcStage+          , next.stage+          , SomeStruct+              zero+                { Vk.srcAccessMask = srcAccess+                , Vk.dstAccessMask = next.access+                , Vk.oldLayout = if discards then Vk.IMAGE_LAYOUT_UNDEFINED else cur.layout+                , Vk.newLayout = next.layout+                , -- IGNORED (not 0): a plain transition, not an ownership+                  -- transfer ('transferOwnership' emits those).+                  Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+                , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED+                , Vk.image = mi.image+                , Vk.subresourceRange = mi.range+                }+          )+    else+      pure Nothing++{- | Descriptor for a 'ManagedImage'; carries the image's 'describedAs'+summary for visualization output (the resource name travels separately).+-}+newtype ImageDesc = ImageDesc {info :: Text}++{- | Import a 'ManagedImage' under @name@, as an observed resource.++Also claims the graph's 'FG.addPreExec slot for 'flushBarriers', so the+hook-queued barriers are recorded under any driver — the adapter owns that+slot; wrap the flush rather than replacing it.++Writers of the image become side effects ('FG.importResource'): right for+presentables and anything read outside the graph (readbacks, a next-frame+sampler). For targets only this graph's passes consume, use+'importScratchImage' so demand culling applies.+-}+importManagedImage :: (MonadIO m) => FG.FrameGraph Recorder () -> Text -> ManagedImage -> m (FG.Handle ManagedImage)+importManagedImage graph name mi = do+  FG.addPreExec graph flushBarriers+  disarmHandOff mi+  FG.importResource graph name (ImageDesc mi.info) mi++{- | Drop a hand-off a previous graph's melted acquire left armed.++Run at import, so the unpaired-acquire check sees only this graph's+releases — a stale slot would let it pass and record a barrier from a+frames-old state.+-}+disarmHandOff :: (MonadIO m) => ManagedImage -> m ()+disarmHandOff mi = liftIO (writeIORef mi.releasedRef Nothing)++{- | 'importManagedImage' via 'FG.importScratch', keeping writers subject to demand culling.++The image (and its layout tracking) persists between graphs, but its contents+are only ever consumed through this graph. Passes that feed a between-graphs+consumer must say 'FG.setSideEffect' themselves.+-}+importScratchImage :: (MonadIO m) => FG.FrameGraph Recorder () -> Text -> ManagedImage -> m (FG.Handle ManagedImage)+importScratchImage graph name mi = do+  FG.addPreExec graph flushBarriers+  disarmHandOff mi+  FG.importScratch graph name (ImageDesc mi.info) mi++{- | 'importManagedImage' declaring the queue that owns the image across the+frame boundary ('FG.importOwned'), read off the wrapper's own tracking: a+first touch on another family this frame derives a real release / acquire+pair — the release recorded on the owning queue — instead of the fatal+cross-family read. An image no device queue has touched yet imports+plainly.+-}+importOwnedImage :: (MonadIO m) => FG.FrameGraph Recorder () -> Text -> ManagedImage -> m (FG.Handle ManagedImage)+importOwnedImage graph name mi =+  liftIO (readIORef mi.queueRef) >>= \case+    Nothing -> importManagedImage graph name mi+    Just owner -> do+      FG.addPreExec graph flushBarriers+      disarmHandOff mi+      FG.importOwned graph name (ImageDesc mi.info) mi owner++{- | Declare the queue that owns the image, established outside any graph.++For producers the adapters cannot see — a fenced one-shot bake, an upload+queue — so 'importOwnedImage' has an owner to derive the first hand-off+from. In-graph accesses track this themselves.+-}+claimOwnership :: (MonadIO m) => FG.QueueId -> ManagedImage -> m ()+claimOwnership queue mi = liftIO (writeIORef mi.queueRef (Just queue))

@@ -0,0 +1,354 @@+{-| Command-buffer routing and barrier batching for driving 'FG.executeQueued'.++A 'Recorder' is a mutable slot holding the command buffer the current pass — and+the barrier hooks it fires — record into, plus the batch of barriers those hooks+have queued for the pass ('queueBarrier', emitted as one command by+'flushBarriers' from the graph's 'FG.addPreExec point). 'recordingBackend' is+the topology-agnostic 'FG.QueueBackend' that points the recorder at each pass's+queue buffer; 'recordGraph' wraps the whole record step (fresh recorder, flush+installed, run, close every buffer), leaving each driver to supply only its own+submit policy.++Nothing here is resource-specific beyond the barrier payload types (one lane+per kind): it is the execution seam any 'FG.Resource' adapter records through.+-}+module Vulkan.Utils.FrameGraph.Recorder+  ( Recorder+  , newRecorder+  , setRecorder+  , setRecorderHost+  , clearChained+  , chainedNode+  , markChained+  , recorderHost+  , setRecorderFamilies+  , recorderFamily+  , recorderSameFamily+  , Accessor (..)+  , TransferSide (..)+  , recorderCommandBuffer+  , recorderQueue+  , Barriers (..)+  , queueBarrier+  , queueBufferBarrier+  , overlappingRanges+  , flushBarriers+  , takeBarriers+  , recordingCommandBuffer+  , recordingBackend+  , recordGraph+  , recordGraphSyncs+  ) where++import Control.Monad (unless, void, when)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Bits ((.&.), (.|.))+import Data.Foldable (traverse_)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Vector qualified as V+import Data.Word (Word32)++import Fragr qualified as FG+import Vulkan.CStruct.Extends (SomeStruct (..))+import Vulkan.Core10 qualified as Vk+import Vulkan.Zero (zero)++{- | The command buffer the barrier hooks (and a pass's exec callback) record+into, tagged with its queue so resource adapters can tell when consecutive+accesses cross queues, plus the pass's pending barrier batch. For single-queue+'FG.execute' it holds one buffer for the whole frame; the multi-queue+'FG.executeQueued' driver swaps it per pass so each queue's work lands in that+queue's buffer.+-}+data Recorder = Recorder+  { slot :: IORef (FG.QueueId, Vk.CommandBuffer)+  , pending :: IORef Barriers+  , host :: IORef Bool+  -- ^ Host mode: the current pass has no command buffer ('setRecorderHost').+  , chained :: IORef IntSet+  {- ^ Nodes whose dependency this pass already synchronized: a split-barrier+  event it waited on, or an ownership acquire it performed.+  -}+  , familyOf :: IORef (Maybe (FG.QueueId -> Word32))+  {- ^ The queue family behind each 'FG.QueueId' ('setRecorderFamilies');+  'Nothing' until a driver provides one, when distinct queues are+  conservatively treated as distinct families.+  -}+  }++-- | The barriers queued for the current pass, OR-ing the stage scopes.+data Barriers = Barriers+  { srcStage :: !Vk.PipelineStageFlags+  , dstStage :: !Vk.PipelineStageFlags+  , images :: [SomeStruct Vk.ImageMemoryBarrier]+  , buffers :: [SomeStruct Vk.BufferMemoryBarrier]+  }++noBarriers :: Barriers+noBarriers = Barriers zero zero [] []++-- | A recorder pointed at an initial buffer on queue 0; swap it with 'setRecorder'.+newRecorder :: (MonadIO m) => Vk.CommandBuffer -> m Recorder+newRecorder cb =+  liftIO $+    Recorder+      <$> newIORef (FG.QueueId 0, cb)+      <*> newIORef noBarriers+      <*> newIORef False+      <*> newIORef IntSet.empty+      <*> newIORef Nothing++-- | Point the recorder at the queue's command buffer the next passes record into.+setRecorder :: (MonadIO m) => Recorder -> FG.QueueId -> Vk.CommandBuffer -> m ()+setRecorder rec queue cb = liftIO do+  writeIORef rec.slot (queue, cb)+  writeIORef rec.host False++{- | Point the recorder at a host-executed pass.++Host work records no commands: the hooks still fire — advancing each+resource's tracked state so later device accesses diff correctly — but the+barriers they queue are dropped. The device-side half of a host access is+the producer's ('FG.preRelease' transitions the resource into the host+state in the producing queue's buffer), and its ordering is the schedule's+timeline wait, realised by the driver executing the pass.+-}+setRecorderHost :: (MonadIO m) => Recorder -> FG.QueueId -> m ()+setRecorderHost rec queue = liftIO do+  modifyIORef' rec.slot (\(_, cb) -> (queue, cb))+  writeIORef rec.host True++{- | Drop the chained marks, at the start of each pass.++They are per-pass: a mark left over from the previous one would suppress a+barrier this pass genuinely needs.+-}+clearChained :: (MonadIO m) => Recorder -> m ()+clearChained rec = liftIO (writeIORef rec.chained mempty)++-- | Whether the node's dependency this pass already synchronized.+chainedNode :: (MonadIO m) => Recorder -> Int -> m Bool+chainedNode rec node = liftIO (IntSet.member node <$> readIORef rec.chained)++{- | Mark a node as already synchronized for the current pass.++The ownership-acquire hook does this: the acquire barrier it emitted carries+the full dependency, so the pass's own declared access must not re-place one.+-}+markChained :: (MonadIO m) => Recorder -> Int -> m ()+markChained rec node = liftIO (modifyIORef' rec.chained (IntSet.insert node))++-- | The queue-family table an ownership transfer names its two sides from.+setRecorderFamilies :: (MonadIO m) => Recorder -> (FG.QueueId -> Word32) -> m ()+setRecorderFamilies rec families = liftIO (writeIORef rec.familyOf (Just families))++{- | The family behind a 'FG.QueueId'.++@QUEUE_FAMILY_IGNORED@ when no table was set: ownership transfers then melt+to plain transitions, matching a driver that never crosses families.+-}+recorderFamily :: (MonadIO m) => Recorder -> FG.QueueId -> m Word32+recorderFamily rec queue = liftIO (maybe Vk.QUEUE_FAMILY_IGNORED ($ queue) <$> readIORef rec.familyOf)++{- | Whether two queues belong to one family, for per-access comparisons.++Without a table ('setRecorderFamilies') this is queue identity: distinct+queues must be assumed to be distinct families, or an EXCLUSIVE resource+crossing them would silently lose the fatal unshared-read diagnostic.+-}+recorderSameFamily :: (MonadIO m) => Recorder -> m (FG.QueueId -> FG.QueueId -> Bool)+recorderSameFamily rec = liftIO (maybe (==) (\f a b -> f a == f b) <$> readIORef rec.familyOf)++{- | Who is performing an access: a device queue, or the host.++The host is not a queue family — its accesses order through the schedule's+timeline and the producer's release barrier, so they never transfer+ownership.+-}+data Accessor+  = DeviceQueue FG.QueueId+  | HostAccess+  deriving stock (Eq, Show)++-- | Which half of a cross-queue hand-off a barrier is.+data TransferSide = Release | Acquire+  deriving stock (Eq, Show)++-- | Whether the current pass runs on the host ('setRecorderHost').+recorderHost :: (MonadIO m) => Recorder -> m Bool+recorderHost rec = liftIO (readIORef rec.host)++-- | The command buffer currently selected.+recorderCommandBuffer :: (MonadIO m) => Recorder -> m Vk.CommandBuffer+{-# INLINE recorderCommandBuffer #-}+recorderCommandBuffer rec = liftIO (snd <$> readIORef rec.slot)++-- | The queue the current pass records on.+recorderQueue :: (MonadIO m) => Recorder -> m FG.QueueId+{-# INLINE recorderQueue #-}+recorderQueue rec = liftIO (fst <$> readIORef rec.slot)++{- | Queue a barrier into the current pass's batch instead of recording it.++A barrier overlapping a subresource already in the batch flushes it first:+barriers in one command are unordered, and an overlapping pair (a pass+reading then writing one image) is a dependent chain of layout transitions+that needs the command split to stay ordered.++The batch is emitted by 'flushBarriers', which the graph must fire between+the hooks and the exec callback (installed via 'FG.addPreExec by the image+adapter's import and by 'recordGraph') — a driver whose resources queue+through another path must install it itself, or the queued barriers are+never recorded.+-}+queueBarrier+  :: (MonadIO m)+  => Recorder+  -> Vk.PipelineStageFlags+  -> Vk.PipelineStageFlags+  -> SomeStruct Vk.ImageMemoryBarrier+  -> m ()+queueBarrier rec src dst barrier = do+  hosted <- liftIO (readIORef rec.host)+  unless hosted do+    Barriers{images} <- liftIO (readIORef rec.pending)+    when (any (overlapping barrier) images) (flushBarriers rec)+    liftIO $ modifyIORef' rec.pending \b ->+      b{srcStage = b.srcStage .|. src, dstStage = b.dstStage .|. dst, images = barrier : b.images}++-- | 'queueBarrier' for the buffer lane; overlap is per whole buffer.+queueBufferBarrier+  :: (MonadIO m)+  => Recorder+  -> Vk.PipelineStageFlags+  -> Vk.PipelineStageFlags+  -> SomeStruct Vk.BufferMemoryBarrier+  -> m ()+queueBufferBarrier rec src dst barrier@(SomeStruct new) = do+  hosted <- liftIO (readIORef rec.host)+  unless hosted do+    Barriers{buffers} <- liftIO (readIORef rec.pending)+    when (any (\(SomeStruct b) -> b.buffer == new.buffer) buffers) (flushBarriers rec)+    liftIO $ modifyIORef' rec.pending \b ->+      b{srcStage = b.srcStage .|. src, dstStage = b.dstStage .|. dst, buffers = barrier : b.buffers}++-- | Whether two image barriers touch overlapping subresources.+overlapping :: SomeStruct Vk.ImageMemoryBarrier -> SomeStruct Vk.ImageMemoryBarrier -> Bool+overlapping (SomeStruct a) (SomeStruct b) =+  a.image == b.image && overlappingRanges a.subresourceRange b.subresourceRange++-- | Whether two subresource ranges of one image intersect.+overlappingRanges :: Vk.ImageSubresourceRange -> Vk.ImageSubresourceRange -> Bool+overlappingRanges ra rb =+  ra.aspectMask .&. rb.aspectMask /= zero+    && spans ra.baseMipLevel ra.levelCount rb.baseMipLevel rb.levelCount+    && spans ra.baseArrayLayer ra.layerCount rb.baseArrayLayer rb.layerCount+  where+    -- The REMAINING_* sentinels are maxBound: treat as extending to the end.+    spans baseA countA baseB countB = baseA < end baseB countB && baseB < end baseA countA+    end base count = if count == maxBound then maxBound else base + count++{- | Drain the queued batch without recording it.++What 'flushBarriers' would have emitted, handed to the caller instead: the+seam for verifying the hooks' barriers without a device (see the test+suite's ownership-transfer group).+-}+takeBarriers :: (MonadIO m) => Recorder -> m Barriers+takeBarriers rec = liftIO (atomicModifyIORef' rec.pending \b -> (noBarriers, b))++{- | Record the pending batch as one @vkCmdPipelineBarrier@ into the current+buffer and clear it; a no-op when nothing is queued.++The stage masks are the OR of every queued barrier's — a slightly wider (never+weaker) dependency than per-barrier commands, the price of batching.+-}+flushBarriers :: (MonadIO m) => Recorder -> m ()+flushBarriers rec = liftIO do+  -- Peek before draining: this runs once per import per pass, nearly always+  -- on an empty batch, so the empty case must stay a plain read.+  peeked <- readIORef rec.pending+  case (peeked.images, peeked.buffers) of+    ([], []) -> pure ()+    _ -> do+      Barriers{srcStage, dstStage, images, buffers} <- takeBarriers rec+      (_queue, cb) <- readIORef rec.slot+      Vk.cmdPipelineBarrier cb srcStage dstStage zero [] (V.fromList buffers) (V.fromList images)++-- | The command buffer the executing pass records into ('recorderCommandBuffer' of the 'FG.Exec' context).+recordingCommandBuffer :: FG.Exec Recorder alloc Vk.CommandBuffer+{-# INLINE recordingCommandBuffer #-}+recordingCommandBuffer = recorderCommandBuffer =<< FG.askCtx++{- | A 'FG.QueueBackend' that routes each pass's recording to its queue's command+buffer (via @cbFor@) and does nothing else.++The topology-agnostic core an 'FG.executeQueued' driver is built on: it only+points the 'Recorder' at the right buffer before each pass. The rest of a+schedule — timeline waits/signals, split-barrier events, queue-family ownership+— is the caller's to realise from 'FG.PassSync' / 'FG.snapshot' around it. On a+single-queue schedule @cbFor = const theOnlyBuffer@ and it degenerates to+recording everything into one buffer.+-}+recordingBackend :: Recorder -> (FG.QueueId -> Vk.CommandBuffer) -> FG.QueueBackend+recordingBackend recorder cbFor =+  FG.QueueBackend+    { FG.beforePass = \psync -> do+        -- Chained marks are per-pass; a stale one would suppress a barrier.+        clearChained recorder+        setRecorder recorder psync.queue (cbFor psync.queue)+    , FG.afterPass = \_ -> pure ()+    , FG.invoke = \_ body -> body+    , FG.completed = pure []+    }++{- | Record a compiled graph into the given per-queue command buffers: point a+fresh recorder at the first buffer, install the 'flushBarriers' flush, drive+'FG.executeQueued' (routing each pass to @cbFor@), then end every buffer. The+caller supplies only the submit that follows.++Runs without a 'FG.RecycleQueue': import-only adapters never retire a+resource, so there is nothing to reclaim (allocate transients in the frame's own+resource scope instead). The first buffer is the primary the recorder starts on;+all buffers are ended.+-}+recordGraph+  :: (MonadIO m)+  => (FG.QueueId -> Vk.CommandBuffer)+  -> NonEmpty Vk.CommandBuffer+  -> FG.FrameGraph Recorder ()+  -> m ()+recordGraph cbFor buffers graph = void (recordGraphSyncs cbFor buffers graph)++{- | 'recordGraph', handing back each executed pass's 'FG.PassSync'.++In execution order, for a caller deriving its submits from the schedule+(see "Vulkan.Utils.FrameGraph.Driver" for the packaged one).+-}+recordGraphSyncs+  :: (MonadIO m)+  => (FG.QueueId -> Vk.CommandBuffer)+  -> NonEmpty Vk.CommandBuffer+  -> FG.FrameGraph Recorder ()+  -> m [FG.PassSync]+recordGraphSyncs cbFor buffers graph = do+  recorder <- newRecorder (NE.head buffers)+  syncs <- liftIO (newIORef [])+  FG.addPreExec graph flushBarriers+  -- The release hooks queue producer-side barriers after the pass body.+  FG.addPostExec graph flushBarriers+  let+    routing = recordingBackend recorder cbFor+    collecting =+      routing+        { FG.beforePass = \psync -> do+            modifyIORef' syncs (psync :)+            routing.beforePass psync+        }+  FG.executeQueued graph collecting Nothing recorder ()+  traverse_ Vk.endCommandBuffer buffers+  liftIO (reverse <$> readIORef syncs)

@@ -0,0 +1,71 @@+{-| Swapchain images as frame-graph imports.++Every windowed frame graph ends the same way: some pass writes the acquired+swapchain image and it must reach @PRESENT_SRC@ before the present.+'newSwapchainImages' builds the persistent per-image 'ManagedImage' table,+'importSwapchain' imports the acquired image from it each frame, and+'presentSwapchain' appends the terminal pass. Skipping the terminal pass (or+reading instead of writing) presents the image stuck in the last writer's+layout, with nothing in the types to catch it.+-}+module Vulkan.Utils.FrameGraph.Swapchain+  ( newSwapchainImages+  , forgetSwapchainImages+  , importSwapchain+  , presentSwapchain+  ) where++import Control.Monad.IO.Class (MonadIO)+import Data.Foldable (traverse_)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Word (Word32)++import Fragr qualified as FG+import Vulkan.Core10 qualified as Vk+import Vulkan.Extensions.VK_KHR_surface qualified+import Vulkan.Utils.FrameGraph.Image (ManagedImage, SliceRegistry, Usage (Present), describedImage, forgetImage, importManagedImage)+import Vulkan.Utils.FrameGraph.Recorder (Recorder)+import Vulkan.Utils.Swapchain (Swapchain (..))++{- | Wrap each swapchain image in a layout-tracked 'ManagedImage'.++The table persists for the swapchain's lifetime — the tracked layouts carry+across frames — so build it once per (re)created swapchain, next to the other+per-swapchain bindings. The images belong to the swapchain; the wrappers need+no release.+-}+newSwapchainImages :: (MonadIO m) => SliceRegistry -> Swapchain -> m (Vector ManagedImage)+newSwapchainImages reg sc =+  traverse+    (\image -> describedImage reg sc.sFormat.format sc.sExtent image Vk.IMAGE_ASPECT_COLOR_BIT)+    sc.sImages++{- | Drop this swapchain's image wrappers from the registry.++A retiring swapchain's handles may be recycled into the next one's images;+call this next to 'newSwapchainImages' when recreating, so the old wrappers+are gone before the new table re-wraps whatever handles come back.+-}+forgetSwapchainImages :: (MonadIO m) => SliceRegistry -> Swapchain -> m ()+forgetSwapchainImages reg sc = traverse_ (forgetImage reg) sc.sImages++{- | Import the acquired image (as @swapchain@) into this frame's graph.++Returns the handle for the graph's writes alongside the wrapper, whose+@.image@ the writing pass records into.+-}+importSwapchain :: (MonadIO m) => FG.FrameGraph Recorder () -> Vector ManagedImage -> Word32 -> m (FG.Handle ManagedImage, ManagedImage)+importSwapchain graph swapImages imageIndex = do+  let mi = swapImages V.! fromIntegral imageIndex+  h <- importManagedImage graph "swapchain" mi+  pure (h, mi)++{- | Terminal present pass over the written swapchain handle.++'FG.finalize' registers a side-effecting pass on the writer's queue, so the+chain survives demand culling and the write hook brings the image to+@PRESENT_SRC@ — a no-op barrier when it is already there (an idle re-present).+-}+presentSwapchain :: (MonadIO m) => FG.FrameGraph Recorder () -> FG.Handle ManagedImage -> m ()+presentSwapchain graph h = FG.finalize graph h Present

@@ -0,0 +1,586 @@+module Main (main) where++import Control.Exception (ErrorCall, try)+import Control.Monad (void)+import Data.Bits ((.|.))+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet qualified as IntSet+import Data.List (sort, subsequences)+import Data.Word (Word32, Word64)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++import Fragr qualified as FG+import Vulkan.CStruct.Extends (SomeStruct (..))+import Vulkan.Core10 qualified as Vk+import Vulkan.Utils.FrameGraph.Aliasing (Candidate (..), happensBefore, planAliases, scheduleOf)+import Vulkan.Utils.FrameGraph.Buffer (ManagedBuffer (..), newManagedBuffer)+import Vulkan.Utils.FrameGraph.Buffer qualified as Buffer+import Vulkan.Utils.FrameGraph.Image (ManagedImage (..), newManagedImage, newManagedImageLayer, newManagedImageMip, newSliceRegistry)+import Vulkan.Utils.FrameGraph.Image qualified as Image+import Vulkan.Utils.FrameGraph.Recorder (Barriers (..), Recorder, TransferSide (..), chainedNode, newRecorder, recorderQueue, recordingBackend, setRecorder, setRecorderFamilies, setRecorderHost, takeBarriers)+import Vulkan.Zero (zero)++main :: IO ()+main = defaultMain (testGroup "vulkan-utils-framegraph" [ordering, aliasing, exhaustive, slices, transfers, boundary])++----------------------------------------------------------------+-- Slice wrap registry+----------------------------------------------------------------++{- | Expect the wrap to be rejected; touch @alive@ after, so the clashing+wrapper stays reachable through the check's garbage collection.+-}+rejectedOver :: ManagedImage -> IO ManagedImage -> IO ()+rejectedOver alive wrap =+  try @ErrorCall wrap >>= \case+    Left _ -> void (readIORef alive.stateRef)+    Right _ -> assertFailure "overlapping wrap accepted"++img :: Vk.Image+img = Vk.Image 1++slices :: TestTree+slices =+  testGroup+    "slice wrap registry"+    [ testCase "disjoint mips of one image wrap fine" do+        reg <- newSliceRegistry+        _ <- newManagedImageMip reg img Vk.IMAGE_ASPECT_COLOR_BIT 0+        void (newManagedImageMip reg img Vk.IMAGE_ASPECT_COLOR_BIT 1)+    , testCase "a second wrapper over a live mip is fatal" do+        reg <- newSliceRegistry+        a <- newManagedImageMip reg img Vk.IMAGE_ASPECT_COLOR_BIT 0+        rejectedOver a (newManagedImageMip reg img Vk.IMAGE_ASPECT_COLOR_BIT 0)+    , testCase "a whole-image wrapper clashes with a live mip" do+        reg <- newSliceRegistry+        a <- newManagedImageMip reg img Vk.IMAGE_ASPECT_COLOR_BIT 3+        rejectedOver a (newManagedImage reg img Vk.IMAGE_ASPECT_COLOR_BIT)+    , testCase "disjoint aspects of one subresource wrap fine" do+        reg <- newSliceRegistry+        _ <- newManagedImage reg img Vk.IMAGE_ASPECT_DEPTH_BIT+        void (newManagedImage reg img Vk.IMAGE_ASPECT_STENCIL_BIT)+    , testCase "mip vs layer wrappers clash where they intersect" do+        reg <- newSliceRegistry+        -- Both cover (mip 0, layer 0).+        a <- newManagedImageMip reg img Vk.IMAGE_ASPECT_COLOR_BIT 0+        rejectedOver a (newManagedImageLayer reg img Vk.IMAGE_ASPECT_COLOR_BIT 0)+    , testCase "dropping the old wrapper legalizes the re-wrap" do+        reg <- newSliceRegistry+        void (newManagedImage reg img Vk.IMAGE_ASPECT_COLOR_BIT)+        -- The registry collects before accusing, so the dropped wrapper's+        -- entry dies here instead of poisoning the image forever.+        void (newManagedImage reg img Vk.IMAGE_ASPECT_COLOR_BIT)+    , -- The renderer-scope semantics: a new scope's registry owes nothing to+      -- the old one's wrappers, even while they are still reachable.+      testCase "a fresh registry accepts a handle another one holds live" do+        old <- newSliceRegistry+        a <- newManagedImage old img Vk.IMAGE_ASPECT_COLOR_BIT+        reg <- newSliceRegistry+        _ <- newManagedImage reg img Vk.IMAGE_ASPECT_COLOR_BIT+        void (readIORef a.stateRef)+    ]++----------------------------------------------------------------+-- Ownership transfer: the QFOT pair semantics, no device+----------------------------------------------------------------++-- | Queues 0 and 2 share family 0; queue 1 is family 1; queue 3 is the host.+family :: FG.QueueId -> Word32+family (FG.QueueId q) = case q of+  0 -> 0+  1 -> 1+  2 -> 0+  _ -> Vk.QUEUE_FAMILY_IGNORED++{- | A recorder over a null command buffer: the hooks' barriers are only ever+drained with 'takeBarriers', never flushed into it — so every hook call is+followed by a drain, keeping the batch's overlap flush unreachable.+-}+fakeRecorder :: IO Recorder+fakeRecorder = do+  rec <- newRecorder zero+  setRecorderFamilies rec family+  pure rec++onQueue :: Recorder -> Int -> IO ()+onQueue rec q = setRecorder rec (FG.QueueId q) zero++-- | Freshly wrapped (through @wrap@), brought to 'Image.ColorAttachment' on queue 0.+producedImageWith :: (ManagedImage -> ManagedImage) -> Recorder -> IO ManagedImage+producedImageWith wrap rec = do+  reg <- newSliceRegistry+  mi <- wrap <$> newManagedImage reg img Vk.IMAGE_ASPECT_COLOR_BIT+  onQueue rec 0+  Image.queueTransition rec 0 mi Image.ColorAttachment+  _ <- takeBarriers rec+  pure mi++producedImage :: Recorder -> IO ManagedImage+producedImage = producedImageWith id++-- | Freshly wrapped and storage-written on queue 0.+producedBuffer :: Recorder -> IO ManagedBuffer+producedBuffer rec = do+  mb <- newManagedBuffer buf+  onQueue rec 0+  Buffer.queueTransition rec 0 mb storageWrite+  _ <- takeBarriers rec+  pure mb++buf :: Vk.Buffer+buf = Vk.Buffer 2++-- | The batch's single image barrier: (families, layouts, access masks).+imageHalf :: Barriers -> IO ((Word32, Word32), (Vk.ImageLayout, Vk.ImageLayout), (Vk.AccessFlags, Vk.AccessFlags))+imageHalf b = case b.images of+  [SomeStruct ib] ->+    pure+      ( (ib.srcQueueFamilyIndex, ib.dstQueueFamilyIndex)+      , (ib.oldLayout, ib.newLayout)+      , (ib.srcAccessMask, ib.dstAccessMask)+      )+  bs -> assertFailure ("expected one image barrier, got " <> show (length bs))++-- | The batch's single buffer barrier: (families, access masks).+bufferHalf :: Barriers -> IO ((Word32, Word32), (Vk.AccessFlags, Vk.AccessFlags))+bufferHalf b = case b.buffers of+  [SomeStruct bb] ->+    pure+      ( (bb.srcQueueFamilyIndex, bb.dstQueueFamilyIndex)+      , (bb.srcAccessMask, bb.dstAccessMask)+      )+  bs -> assertFailure ("expected one buffer barrier, got " <> show (length bs))++sampled :: Image.Usage+sampled = Image.Sampled Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT++storage :: Image.Usage+storage = Image.StorageRead Vk.PIPELINE_STAGE_COMPUTE_SHADER_BIT++storageWrite :: Buffer.Usage+storageWrite = Buffer.StorageWrite Vk.PIPELINE_STAGE_COMPUTE_SHADER_BIT++storageRead :: Buffer.Usage+storageRead = Buffer.StorageRead Vk.PIPELINE_STAGE_COMPUTE_SHADER_BIT++transfers :: TestTree+transfers =+  testGroup+    "ownership transfer"+    [ testCase "an owned hand-off records matching release/acquire halves" do+        rec <- fakeRecorder+        mi <- producedImage rec+        Image.transferOwnership Release rec 7 (FG.QueueId 1) mi sampled+        (relFams, relLayouts, relAccess) <- imageHalf =<< takeBarriers rec+        relFams @?= (0, 1)+        relLayouts @?= (Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL)+        relAccess @?= (Vk.ACCESS_COLOR_ATTACHMENT_READ_BIT .|. Vk.ACCESS_COLOR_ATTACHMENT_WRITE_BIT, zero)+        -- The release performs the transition; the slot keeps the state it saw.+        readIORef mi.releasedRef >>= (@?= Just (Image.usageState Image.ColorAttachment))+        readIORef mi.stateRef >>= (@?= Image.usageState sampled)+        onQueue rec 1+        Image.transferOwnership Acquire rec 7 (FG.QueueId 0) mi sampled+        (acqFams, acqLayouts, acqAccess) <- imageHalf =<< takeBarriers rec+        -- The spec wants the halves identical up to the ignored scopes.+        acqFams @?= relFams+        acqLayouts @?= relLayouts+        acqAccess @?= (zero, Vk.ACCESS_SHADER_READ_BIT)+        readIORef mi.releasedRef >>= (@?= Nothing)+        readIORef mi.queueRef >>= (@?= Just (FG.QueueId 1))+        chainedNode rec 7 >>= assertBool "the acquire marks the node chained"+    , testCase "a melted acquire leaves the hand-off for a pending owned one" do+        rec <- fakeRecorder+        mi <- producedImage rec+        -- One version, two transfers: a host readback plus an owned hand-off+        -- to family 1 — the shape a host + device fan-out compiles to.+        Image.transferOwnership Release rec 7 (FG.QueueId 3) mi Image.HostRead+        _ <- takeBarriers rec+        Image.transferOwnership Release rec 8 (FG.QueueId 1) mi storage+        (relFams, relLayouts, _) <- imageHalf =<< takeBarriers rec+        relFams @?= (0, 1)+        -- The host's melted acquire must not spend the slot the owned one needs.+        setRecorderHost rec (FG.QueueId 3)+        Image.transferOwnership Acquire rec 7 (FG.QueueId 0) mi Image.HostRead+        readIORef mi.releasedRef >>= (@?= Just (Image.usageState Image.HostRead))+        onQueue rec 1+        Image.transferOwnership Acquire rec 8 (FG.QueueId 0) mi storage+        (acqFams, acqLayouts, _) <- imageHalf =<< takeBarriers rec+        acqFams @?= relFams+        acqLayouts @?= relLayouts+        readIORef mi.releasedRef >>= (@?= Nothing)+    , testCase "a late host acquire does not rewind the device tracking" do+        rec <- fakeRecorder+        mi <- producedImage rec+        -- The same fan-out, but hooks in the Driver's real order: it defers+        -- host passes, so the owned acquire lands before the host's melted one.+        Image.transferOwnership Release rec 7 (FG.QueueId 3) mi Image.HostRead+        _ <- takeBarriers rec+        Image.transferOwnership Release rec 8 (FG.QueueId 1) mi storage+        _ <- takeBarriers rec+        onQueue rec 1+        Image.transferOwnership Acquire rec 8 (FG.QueueId 0) mi storage+        _ <- takeBarriers rec+        setRecorderHost rec (FG.QueueId 3)+        Image.transferOwnership Acquire rec 7 (FG.QueueId 0) mi Image.HostRead+        readIORef mi.stateRef >>= (@?= Image.usageState storage)+        readIORef mi.queueRef >>= (@?= Just (FG.QueueId 1))+    , testCase "an owned acquire without its release half is fatal" do+        rec <- fakeRecorder+        mi <- producedImage rec+        Image.transferOwnership Release rec 7 (FG.QueueId 1) mi sampled+        _ <- takeBarriers rec+        onQueue rec 1+        Image.transferOwnership Acquire rec 7 (FG.QueueId 0) mi sampled+        _ <- takeBarriers rec+        -- The slot is single-use: a duplicate acquire cannot replay the+        -- consumed hand-off, and recording a guessed half would be worse.+        try @ErrorCall (Image.transferOwnership Acquire rec 8 (FG.QueueId 0) mi sampled) >>= \case+          Left _ -> pure ()+          Right () -> assertFailure "an unpaired owned acquire was accepted"+    , testCase "a CONCURRENT hand-off is a producer-side transition, no families named" do+        rec <- fakeRecorder+        mi <- producedImageWith Image.sharedAcrossQueues rec+        Image.transferOwnership Release rec 7 (FG.QueueId 1) mi sampled+        (fams, layouts, _) <- imageHalf =<< takeBarriers rec+        fams @?= (Vk.QUEUE_FAMILY_IGNORED, Vk.QUEUE_FAMILY_IGNORED)+        layouts @?= (Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL)+        onQueue rec 1+        Image.transferOwnership Acquire rec 7 (FG.QueueId 0) mi sampled+        acq <- takeBarriers rec+        assertBool "the acquire half melts" (null acq.images)+    , testCase "a same-family hop chains to the semaphore, keeping contents" do+        rec <- fakeRecorder+        mi <- producedImage rec+        onQueue rec 2+        Image.queueTransition rec 1 mi sampled+        (fams, layouts, access) <- imageHalf =<< takeBarriers rec+        fams @?= (Vk.QUEUE_FAMILY_IGNORED, Vk.QUEUE_FAMILY_IGNORED)+        layouts @?= (Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL)+        -- The semaphore already made the writes available.+        fst access @?= zero+    , testCase "a cross-family write acquires by discarding" do+        rec <- fakeRecorder+        mi <- producedImage rec+        onQueue rec 1+        Image.queueTransition rec 1 mi Image.TransferDst+        (fams, layouts, _) <- imageHalf =<< takeBarriers rec+        fams @?= (Vk.QUEUE_FAMILY_IGNORED, Vk.QUEUE_FAMILY_IGNORED)+        layouts @?= (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL)+    , testCase "a cross-family read of an unshared image is fatal" do+        rec <- fakeRecorder+        mi <- producedImage rec+        onQueue rec 1+        try @ErrorCall (Image.queueTransition rec 1 mi sampled) >>= \case+          Left _ -> pure ()+          Right () -> assertFailure "an unhanded cross-family read was accepted"+    , testCase "the buffer pair mirrors the image rules, minus layout" do+        rec <- fakeRecorder+        mb <- producedBuffer rec+        Buffer.transferOwnership Release rec 7 (FG.QueueId 1) mb storageRead+        (relFams, relAccess) <- bufferHalf =<< takeBarriers rec+        relFams @?= (0, 1)+        relAccess @?= (Vk.ACCESS_SHADER_WRITE_BIT, zero)+        readIORef mb.releasedRef >>= (@?= Just (Buffer.usageState storageWrite))+        onQueue rec 1+        Buffer.transferOwnership Acquire rec 7 (FG.QueueId 0) mb storageRead+        (acqFams, acqAccess) <- bufferHalf =<< takeBarriers rec+        acqFams @?= relFams+        acqAccess @?= (zero, Vk.ACCESS_SHADER_READ_BIT)+        readIORef mb.releasedRef >>= (@?= Nothing)+        readIORef mb.queueRef >>= (@?= Just (FG.QueueId 1))+    , testCase "a melted buffer release records nothing but arms the slot" do+        rec <- fakeRecorder+        mb <- producedBuffer rec+        -- No layout to move: a same-family release is pure bookkeeping.+        Buffer.transferOwnership Release rec 7 (FG.QueueId 2) mb storageRead+        melted <- takeBarriers rec+        assertBool "a same-family release records no barrier" (null melted.buffers)+        onQueue rec 2+        Buffer.transferOwnership Acquire rec 7 (FG.QueueId 0) mb storageRead+        readIORef mb.releasedRef >>= (@?= Just (Buffer.usageState storageWrite))+    ]++----------------------------------------------------------------+-- Frame-boundary ownership: importOwned* driven end to end, no device+----------------------------------------------------------------++{- | A graph collecting every non-empty barrier batch as (queue, batch).+The drains are installed /before/ the import claims the flush slot, so+'Vulkan.Utils.FrameGraph.Recorder.flushBarriers' always finds an empty+batch and the zero command buffer is never recorded into.+-}+drainingGraph :: IO (FG.FrameGraph Recorder (), IORef [(FG.QueueId, Barriers)])+drainingGraph = do+  g <- FG.newFrameGraph @Recorder @()+  batches <- newIORef []+  let drain r = do+        q <- recorderQueue r+        b <- takeBarriers r+        case (b.images, b.buffers) of+          ([], []) -> pure ()+          _ -> modifyIORef' batches ((q, b) :)+  FG.addPreExec g drain+  FG.addPostExec g drain+  pure (g, batches)++runBoundary :: Recorder -> FG.FrameGraph Recorder () -> [(FG.QueueId, FG.FamilyId)] -> IO ()+runBoundary rec g partition = do+  FG.compileWith partition g+  FG.executeQueued g (recordingBackend rec (const zero)) Nothing rec ()++-- | The collected batches: an acquire on top of the release it consumed.+boundaryPair :: IORef [(FG.QueueId, Barriers)] -> IO ((FG.QueueId, Barriers), (FG.QueueId, Barriers))+boundaryPair batches =+  readIORef batches >>= \case+    [acq, rel] -> pure (rel, acq)+    bs -> assertFailure ("expected the release and acquire halves, got " <> show (length bs))++boundary :: TestTree+boundary =+  testGroup+    "frame-boundary ownership"+    [ testCase "an owned image import pairs a foreign first read across frames" do+        rec <- fakeRecorder+        mi <- producedImage rec+        (g, batches) <- drainingGraph+        h <- Image.importOwnedImage g "ext" mi+        _ <- FG.addPass g "Sample" (FG.setQueue (FG.QueueId 1) *> FG.readWith h sampled *> FG.setSideEffect) (\_ -> pure ())+        runBoundary rec g [(FG.QueueId 0, FG.FamilyId 0), (FG.QueueId 1, FG.FamilyId 1)]+        ((qr, rel), (qa, acq)) <- boundaryPair batches+        qr @?= FG.QueueId 0+        qa @?= FG.QueueId 1+        (relFams, relLayouts, _) <- imageHalf rel+        (acqFams, acqLayouts, _) <- imageHalf acq+        relFams @?= (0, 1)+        acqFams @?= relFams+        relLayouts @?= (Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL)+        acqLayouts @?= relLayouts+        readIORef mi.releasedRef >>= (@?= Nothing)+        readIORef mi.queueRef >>= (@?= Just (FG.QueueId 1))+    , testCase "the pair melts within the owner's family" do+        rec <- fakeRecorder+        mi <- producedImage rec+        (g, batches) <- drainingGraph+        h <- Image.importOwnedImage g "ext" mi+        _ <- FG.addPass g "Sample" (FG.setQueue (FG.QueueId 2) *> FG.readWith h sampled *> FG.setSideEffect) (\_ -> pure ())+        runBoundary rec g [(FG.QueueId 0, FG.FamilyId 0), (FG.QueueId 2, FG.FamilyId 0)]+        readIORef batches >>= \case+          [(q, rel)] -> do+            q @?= FG.QueueId 0+            (fams, layouts, _) <- imageHalf rel+            -- A same-family hand-off is a producer-side transition, no QFOT.+            fams @?= (Vk.QUEUE_FAMILY_IGNORED, Vk.QUEUE_FAMILY_IGNORED)+            layouts @?= (Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL)+          bs -> assertFailure ("expected one melted release, got " <> show (length bs))+    , testCase "an untouched wrapper imports plainly" do+        rec <- fakeRecorder+        reg <- newSliceRegistry+        mi <- newManagedImage reg img Vk.IMAGE_ASPECT_COLOR_BIT+        (g, batches) <- drainingGraph+        h <- Image.importOwnedImage g "ext" mi+        _ <- FG.addPass g "Draw" (FG.setQueue (FG.QueueId 1) *> FG.writeWith_ h Image.ColorAttachment) (\_ -> pure ())+        runBoundary rec g [(FG.QueueId 0, FG.FamilyId 0), (FG.QueueId 1, FG.FamilyId 1)]+        readIORef batches >>= \case+          [(q, b)] -> do+            q @?= FG.QueueId 1+            (fams, layouts, _) <- imageHalf b+            fams @?= (Vk.QUEUE_FAMILY_IGNORED, Vk.QUEUE_FAMILY_IGNORED)+            layouts @?= (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL)+          bs -> assertFailure ("expected one plain transition, got " <> show (length bs))+    , testCase "an owned buffer import pairs the same way, minus layout" do+        rec <- fakeRecorder+        mb <- producedBuffer rec+        (g, batches) <- drainingGraph+        h <- Buffer.importOwnedBuffer g "ext" mb+        _ <- FG.addPass g "ReadBack" (FG.setQueue (FG.QueueId 1) *> FG.readWith h storageRead *> FG.setSideEffect) (\_ -> pure ())+        runBoundary rec g [(FG.QueueId 0, FG.FamilyId 0), (FG.QueueId 1, FG.FamilyId 1)]+        ((qr, rel), (qa, acq)) <- boundaryPair batches+        qr @?= FG.QueueId 0+        qa @?= FG.QueueId 1+        (relFams, relAccess) <- bufferHalf rel+        (acqFams, acqAccess) <- bufferHalf acq+        relFams @?= (0, 1)+        acqFams @?= relFams+        relAccess @?= (Vk.ACCESS_SHADER_WRITE_BIT, zero)+        acqAccess @?= (zero, Vk.ACCESS_SHADER_READ_BIT)+        readIORef mb.queueRef >>= (@?= Just (FG.QueueId 1))+    ]++----------------------------------------------------------------+-- Exhaustive: every small schedule, against an independent oracle+----------------------------------------------------------------++{- | Every schedule of @n@ passes over @q@ queues, with every combination of+waits — a pass may wait each foreign queue's current watermark, or not.++That is the whole space the compiler can hand us at this size, so the checks+below are not samples: they are closed over it.+-}+schedules :: Int -> Int -> [[FG.PassSync]]+schedules n q = go 0 (replicate q 0) []+  where+    go i counters acc+      | i == n = [reverse acc]+      | otherwise = do+          queue <- [0 .. q - 1]+          -- Wait on any subset of the other queues' latest signals.+          waitMask <- subsequences [j | j <- [0 .. q - 1], j /= queue]+          let+            signal = (counters !! queue) + 1+            counters' = [if j == queue then signal else c | (j, c) <- zip [0 ..] counters]+            waits = [(j, counters !! j) | j <- waitMask, counters !! j > 0]+          go (i + 1) counters' (pass i queue signal waits : acc)++{- | The relation, derived a second way: build the edges explicitly and take+their transitive closure. Deliberately unlike the vector clock it checks —+an oracle that shared the implementation would prove nothing.+-}+oracle :: [FG.PassSync] -> Int -> Int -> Bool+oracle syncs = \i j -> IntSet.member i (IntMap.findWithDefault IntSet.empty j reach)+  where+    indexed = zip [0 ..] syncs+    -- Direct predecessors: the previous pass on the same queue, and every+    -- pass whose signal a wait names at or below its watermark.+    preds s =+      [ i+      | (i, p) <- indexed+      , p.queue == s.queue && p.signal < s.signal+          || or [p.queue == w.queue && p.signal <= w.value | w <- s.waits]+      ]+    -- Transitive closure, accumulated in position order: every predecessor is+    -- at an earlier position, so its own reach set is already in the map.+    reach = foldl step IntMap.empty indexed+    step m (j, s) =+      let ps = preds s+      in IntMap.insert j (IntSet.unions (IntSet.fromList ps : [IntMap.findWithDefault IntSet.empty i m | i <- ps])) m++exhaustive :: TestTree+exhaustive =+  testGroup+    "exhaustive (5 passes, 3 queues, all wait combinations)"+    [ testCase "happensBefore agrees with the closure oracle everywhere" do+        let bad =+              [ (syncs, i, j)+              | syncs <- schedules 5 3+              , let s = scheduleOf syncs+              , let ref = oracle syncs+              , i <- [0 .. 4]+              , j <- [0 .. 4]+              , happensBefore s i j /= ref i j+              ]+        assertBool (show (take 1 bad)) (null bad)+    , -- The invariant the whole feature rests on: anything the planner puts in+      -- one block must be pairwise ordered, so the tenancies cannot overlap.+      testCase "every planned group is pairwise ordered" do+        let bad =+              [ (syncs, x, y)+              | syncs <- schedules 5 3+              , let s = scheduleOf syncs+              , -- One entry per pass, plus a long-lived one spanning the run.+              cs <- [[Candidate i (i, i) | i <- [0 .. 4]], [Candidate 9 (0, 4), Candidate 0 (1, 1), Candidate 1 (2, 3)]]+              , g <- planAliases s cs+              , x <- g+              , y <- g+              , x /= y+              , not (happensBefore s (snd x.live) (fst y.live))+              , not (happensBefore s (snd y.live) (fst x.live))+              ]+        assertBool (show (take 1 bad)) (null bad)+    ]++-- A pass on a queue, signalling a value, waiting on foreign queues.+pass :: Int -> Int -> Word64 -> [(Int, Word64)] -> FG.PassSync+pass pid queue signal waits =+  FG.PassSync+    { FG.passId = pid+    , FG.name = "p"+    , FG.queue = FG.QueueId queue+    , FG.waits = [FG.Wait{FG.queue = FG.QueueId q, FG.value = v, FG.covers = []} | (q, v) <- waits]+    , FG.signal = signal+    , FG.waitEvents = []+    , FG.signalEvents = []+    , FG.acquires = []+    , FG.releases = []+    }++groupIds :: [[Candidate]] -> [[Int]]+groupIds = sort . map (map (.entryId))++ordering :: TestTree+ordering =+  testGroup+    "happensBefore"+    [ testCase "submission order on one queue" do+        let s = scheduleOf [pass 0 0 1 [], pass 1 0 2 []]+        assertBool "0 before 1" (happensBefore s 0 1)+        assertBool "1 not before 0" (not (happensBefore s 1 0))+    , testCase "a pass is not before itself" do+        let s = scheduleOf [pass 0 0 1 []]+        assertBool "irreflexive" (not (happensBefore s 0 0))+    , -- The case positions alone get wrong: two queues, no wait between them.+      -- Position 0 precedes position 1, but they run concurrently.+      testCase "concurrent queues are unordered despite positions" do+        let s = scheduleOf [pass 0 0 1 [], pass 1 1 1 []]+        assertBool "0 not before 1" (not (happensBefore s 0 1))+        assertBool "1 not before 0" (not (happensBefore s 1 0))+    , testCase "a wait orders across queues" do+        -- q1's pass waits for q0's value 1.+        let s = scheduleOf [pass 0 0 1 [], pass 1 1 1 [(0, 1)]]+        assertBool "0 before 1" (happensBefore s 0 1)+        assertBool "1 not before 0" (not (happensBefore s 1 0))+    , testCase "ordering is transitive through a third queue" do+        -- q0:p0 -> q1:p1 (waits q0) -> q2:p2 (waits q1). p0 must precede p2.+        let s = scheduleOf [pass 0 0 1 [], pass 1 1 1 [(0, 1)], pass 2 2 1 [(1, 1)]]+        assertBool "0 before 2 transitively" (happensBefore s 0 2)+        assertBool "2 not before 0" (not (happensBefore s 2 0))+    , testCase "a wait on a later value still orders the earlier pass" do+        -- Watermarked waits name a value, not a pass: waiting q0's 2 must+        -- also observe q0's pass that signalled 1.+        let s = scheduleOf [pass 0 0 1 [], pass 1 0 2 [], pass 2 1 1 [(0, 2)]]+        assertBool "0 before 2" (happensBefore s 0 2)+        assertBool "1 before 2" (happensBefore s 1 2)+    , testCase "a wait does not order passes after the signal" do+        -- q1 waits q0's value 1; q0's *later* pass (value 2) is not ordered.+        let s = scheduleOf [pass 0 0 1 [], pass 1 0 2 [], pass 2 1 1 [(0, 1)]]+        assertBool "1 not before 2" (not (happensBefore s 1 2))+    ]++aliasing :: TestTree+aliasing =+  testGroup+    "planAliases"+    [ testCase "sequential lifetimes on one queue share a block" do+        let+          s = scheduleOf [pass 0 0 1 [], pass 1 0 2 [], pass 2 0 3 []]+          cs = [Candidate 10 (0, 0), Candidate 11 (1, 2)]+        groupIds (planAliases s cs) @?= [[10, 11]]+    , testCase "overlapping lifetimes do not" do+        let+          s = scheduleOf [pass 0 0 1 [], pass 1 0 2 []]+          cs = [Candidate 10 (0, 1), Candidate 11 (1, 1)]+        groupIds (planAliases s cs) @?= [[10], [11]]+    , -- The silent-corruption case: disjoint positions, concurrent queues.+      testCase "disjoint positions on concurrent queues do NOT share" do+        let+          s = scheduleOf [pass 0 0 1 [], pass 1 1 1 []]+          cs = [Candidate 10 (0, 0), Candidate 11 (1, 1)]+        groupIds (planAliases s cs) @?= [[10], [11]]+    , testCase "a wait makes the same two safe to share" do+        let+          s = scheduleOf [pass 0 0 1 [], pass 1 1 1 [(0, 1)]]+          cs = [Candidate 10 (0, 0), Candidate 11 (1, 1)]+        groupIds (planAliases s cs) @?= [[10, 11]]+    , testCase "a group admits a third only if ordered against all of it" do+        -- p0,p1,p2 on q0 (ordered); p3 on q1, unordered with everything.+        let+          s = scheduleOf [pass 0 0 1 [], pass 1 0 2 [], pass 2 0 3 [], pass 3 1 1 []]+          cs = [Candidate 10 (0, 0), Candidate 11 (1, 1), Candidate 12 (2, 2), Candidate 13 (3, 3)]+        groupIds (planAliases s cs) @?= [[10, 11, 12], [13]]+    , testCase "groups come back in takeover order" do+        let+          s = scheduleOf [pass 0 0 1 [], pass 1 0 2 [], pass 2 0 3 []]+          cs = [Candidate 12 (2, 2), Candidate 10 (0, 0), Candidate 11 (1, 1)]+        map (map (.entryId)) (planAliases s cs) @?= [[10, 11, 12]]+    ]

@@ -0,0 +1,103 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack++name:           vulkan-utils-framegraph+version:        0.1.0.0+synopsis:       Vulkan barrier-placement and resource adapter for the fragr frame graph+category:       Graphics+homepage:       https://github.com/haskell-game/vulkan#readme+bug-reports:    https://github.com/haskell-game/vulkan/issues+maintainer:     IC Rainbow <aenor.realm@gmail.com>+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    package.yaml++source-repository head+  type: git+  location: https://github.com/haskell-game/vulkan++library+  exposed-modules:+      Vulkan.Utils.FrameGraph.Aliasing+      Vulkan.Utils.FrameGraph.Buffer+      Vulkan.Utils.FrameGraph.Driver+      Vulkan.Utils.FrameGraph.Image+      Vulkan.Utils.FrameGraph.Recorder+      Vulkan.Utils.FrameGraph.Swapchain+  other-modules:+      Paths_vulkan_utils_framegraph+  autogen-modules:+      Paths_vulkan_utils_framegraph+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      DerivingStrategies+      DuplicateRecordFields+      ImportQualifiedPost+      LambdaCase+      NamedFieldPuns+      NoFieldSelectors+      OverloadedLists+      OverloadedRecordDot+      OverloadedStrings+      RecordWildCards+      ScopedTypeVariables+      StrictData+      TypeApplications+      TypeFamilies+  ghc-options: -Wall+  build-depends:+      base >=4.16 && <5+    , containers+    , fragr+    , resourcet+    , text+    , transformers+    , vector+    , vulkan ==3.27.*+    , vulkan-utils+  default-language: Haskell2010++test-suite vulkan-utils-framegraph-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_vulkan_utils_framegraph+  autogen-modules:+      Paths_vulkan_utils_framegraph+  hs-source-dirs:+      test+  default-extensions:+      BlockArguments+      DerivingStrategies+      DuplicateRecordFields+      ImportQualifiedPost+      LambdaCase+      NamedFieldPuns+      NoFieldSelectors+      OverloadedLists+      OverloadedRecordDot+      OverloadedStrings+      RecordWildCards+      ScopedTypeVariables+      StrictData+      TypeApplications+      TypeFamilies+  ghc-options: -Wall+  build-depends:+      base+    , containers+    , fragr+    , tasty+    , tasty-hunit+    , vector+    , vulkan+    , vulkan-utils-framegraph+  default-language: Haskell2010