Snapshot.hs

-- | Read-only introspection of the graph, for debug output and testing.
module Fragr.Snapshot
  ( Snapshot (..)
  , PassInfo (..)
  , NodeInfo (..)
  , EntryInfo (..)
  , RetireInfo (..)
  , snapshot
  ) where

import Control.Monad.IO.Class (MonadIO (..))
import Data.Foldable (toList)
import Data.IORef (readIORef)
import Data.IntMap.Strict qualified as IntMap
import Data.Maybe (maybeToList)
import Data.Sequence qualified as Seq
import Data.Text (Text)
import Data.Traversable (for)
import Data.Word (Word64)

import Fragr.Compile (canExecute)
import Fragr.Graph (FrameGraph (..), PassNode (..), ResourceEntry (..), ResourceNode (..), describeEntry, touchedNodes)
import Fragr.Resource (Access)
import Fragr.Sync (Compiled (..), PassSync)
import Fragr.Types (QueueId, SomeHandle)

-- | Read-only view of the whole graph, for debug output and testing.
data Snapshot = Snapshot
  { passes :: [PassInfo]
  , nodes :: [NodeInfo]
  , entries :: [EntryInfo]
  , retires :: [RetireInfo]
  }
  deriving stock (Show)

-- | Read-only view of a 'PassNode' (compile-phase state included).
data PassInfo = PassInfo
  { passId :: Int
  , name :: Text
  , creates :: [SomeHandle]
  , reads :: [Access]
  , writes :: [Access]
  , sideEffect :: Bool
  , queue :: QueueId
  , refCount :: Int
  , canExecute :: Bool
  , sync :: Maybe PassSync
  -- ^ the pass's sync schedule after 'Fragr.Compile.compile' ('Nothing' if culled)
  , level :: Maybe Int
  {- ^ The pass's dependency level: the longest chain of ordering edges
  reaching it, counted in edges ('Nothing' if culled). Meaningful only
  after 'Fragr.Compile.compile'.

  Passes sharing a level have no path between them, so nothing orders them
  and they may overlap whatever their queues. The converse does not hold: a
  level gap is a path's /length/, not a path — it never proves two passes
  cannot overlap. The level count is the critical path, and the widest level
  is the concurrency the graph permits.
  -}
  , antiAfter :: [Int]
  {- ^ The executing passes that rename a resource this one reads, and so
  must run after it, though no data flows to them (write-after-read). Empty
  if culled, and before 'Fragr.Compile.compile'.
  -}
  }
  deriving stock (Show)

{- | Read-only view of a transient entry's deferred-reclamation
requirements: the per-queue timeline value that must be reached before it
may be reclaimed. Imports never appear — the graph does not reclaim them.
-}
data RetireInfo = RetireInfo
  { entryId :: Int
  , requirements :: [(QueueId, Word64)]
  }
  deriving stock (Show)

-- | Read-only view of a 'ResourceNode'.
data NodeInfo = NodeInfo
  { nodeId :: Int
  , name :: Text
  , resourceId :: Int
  , version :: Int
  , refCount :: Int
  }
  deriving stock (Show)

-- | Read-only view of a 'ResourceEntry'.
data EntryInfo = EntryInfo
  { entryId :: Int
  , version :: Int
  , imported :: Bool
  , description :: Text
  , live :: Maybe (Int, Int)
  {- ^ The entry's live range over the executing passes, as inclusive
  positions in execution order ('Nothing' when no executing pass touches
  it). Meaningful only after 'Fragr.Compile.compile'.

  Disjoint ranges are the raw material for plan-time aliasing — placing
  two entries in one allocation, decided before recording, with no
  reclamation bookkeeping at run time. Two conditions ride on the backend,
  because the range alone does not carry them:

  * Only entries the graph owns may be aliased: an import's memory belongs
    to the caller, whatever its range says ('imported' tells them apart).

  * Positions order the executing passes globally, but passes on different
    queues run concurrently, so disjoint positions do not imply disjoint
    lifetimes across queues. Only ranges whose passes are ordered — one
    queue, or a pair the schedule already synchronizes — are safe to alias.

  The backend still owes the aliasing barrier at each handover (the second
  user's contents are undefined until it writes them).
  -}
  }
  deriving stock (Show)

{- |
Capture the current state of the graph. Callable at any time, but the
reference counts and culling state are meaningful only after 'compile'.
-}
{-# INLINEABLE snapshot #-}
snapshot :: (MonadIO m) => FrameGraph ctx alloc -> m Snapshot
snapshot g = liftIO do
  passes <- readIORef g.passesRef
  nodes <- readIORef g.nodesRef
  entries <- readIORef g.entriesRef
  compiled <- readIORef g.compiledRef
  let
    refsMap = maybe IntMap.empty (.passRefs) compiled
    passRef p = IntMap.findWithDefault 0 p.passId refsMap
    nodeRef n = maybe 0 (\c -> IntMap.findWithDefault 0 n.nodeId c.nodeRefs) compiled
    passSyncOf p = compiled >>= \c -> IntMap.lookup p.passId c.passSync
    passLevelOf p = compiled >>= \c -> IntMap.lookup p.passId c.passLevel
    passAntiOf p = maybe [] (\c -> IntMap.findWithDefault [] p.passId c.passAnti) compiled
    retireInfos = maybe [] retiresOf compiled
    retiresOf c = do
      (e, reqs) <- IntMap.toList c.entryRetire
      pure RetireInfo{entryId = e, requirements = reqs}
    -- Live ranges: for each entry, the first and last executing pass that
    -- touches any of its versions, as positions in execution order.
    entryOfNode = IntMap.fromList do
      n <- toList nodes
      pure (n.nodeId, n.resourceId)
    executing = maybe [] (\c -> filter (canExecute c.passRefs) (toList passes)) compiled
    liveRanges = IntMap.fromListWith (\(a, b) (c, d) -> (min a c, max b d)) do
      (pos, p) <- zip [0 ..] executing
      node <- touchedNodes p
      rid <- maybeToList (IntMap.lookup node entryOfNode)
      pure (rid, (pos, pos))
  entryInfos <- for (toList entries) \entry -> do
    v <- readIORef entry.versionRef
    pure
      EntryInfo
        { entryId = entry.entryId
        , version = v
        , imported = entry.imported
        , description = describeEntry entry.payload
        , live = IntMap.lookup entry.entryId liveRanges
        }
  pure
    Snapshot
      { passes = do
          p <- toList passes
          pure
            PassInfo
              { passId = p.passId
              , name = p.name
              , creates = p.creates
              , reads = p.reads
              , writes = p.writes
              , sideEffect = p.sideEffect
              , queue = p.queue
              , refCount = passRef p
              , canExecute = canExecute refsMap p
              , sync = passSyncOf p
              , level = passLevelOf p
              , antiAfter = passAntiOf p
              }
      , nodes = do
          n <- toList nodes
          pure
            NodeInfo
              { nodeId = n.nodeId
              , name = (entries `Seq.index` n.resourceId).name
              , resourceId = n.resourceId
              , version = n.version
              , refCount = nodeRef n
              }
      , entries = entryInfos
      , retires = retireInfos
      }