Behavior.hs

-- | The behaviour checklist: culling, lifetimes, hook ordering.
module Spec.Behavior (tests) where

import Control.Exception (evaluate)
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, testCase, (@?=))

import Fragr (QueueId (..))
import Fragr qualified as FG
import Utils

tests :: TestTree
tests =
  testGroup
    "behavior checklist"
    [ creationOrder
    , importedWriteRenames
    , liveRanges
    , dependencyLevels
    , scratchCulledWithoutDemand
    , scratchSurvivesOnDemand
    , renameCarriesFlags
    , emptyPassCulled
    , chainExecutes
    , cullingIsTransitive
    , creatorSurvivesBareRead
    , sideEffectKeepsInputAlive
    , execHooksBracketCallback
    , sinkPassComposes
    , finalizeKeepsChainAlive
    ]

creationOrder :: TestTree
creationOrder = testCase "side-effect pass creates its transients in declaration order" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  (a, c) <-
    FG.addPass
      g
      "P"
      ( do
          a <- FG.create @Tex "A" (tex "A")
          c <- FG.create @Tex "B" (tex "B")
          a' <- FG.write a
          c' <- FG.write c
          FG.setSideEffect
          pure (a', c')
      )
      \(a, c) -> do
        Tex 0 <- FG.get @Tex a
        Tex 1 <- FG.get @Tex c
        ranHere "P"
  FG.compile g
  FG.execute g env env
  _ <- evaluate (a, c)
  ev <- getEvents env
  ev @?= [ECreate "A" 0, ECreate "B" 1, ERun "P", EDestroy "A", EDestroy "B"]

importedWriteRenames :: TestTree
importedWriteRenames = testCase "writing an imported resource renames the handle and forces a side effect" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  h1 <- FG.importResource g "BB" (tex "BB") (Tex 42)
  h2 <-
    FG.addPass
      g
      "Blit"
      (FG.write h1)
      \h -> do
        obj <- FG.get @Tex h
        liftIO (obj @?= Tex 42) -- the imported object itself, not a fresh one
        ranHere "Blit"
  FG.isValid g h1 >>= \v -> v @?= False
  FG.isValid g h2 >>= \v -> v @?= True
  s <- FG.snapshot g
  map (.sideEffect) s.passes @?= [True]
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  -- imported resources are never created nor destroyed by the graph
  ev @?= [ERun "Blit"]

liveRanges :: TestTree
liveRanges = testCase "entry live ranges span the executing passes that touch them" do
  g <- FG.newFrameGraph @Device @Device
  -- A: creates a, B: a -> b, C: b -> c. 'a' dies at B, 'c' is born at C,
  -- so their ranges are disjoint and the two may share memory.
  a <- FG.addPass g "A" (FG.create @Image "a" (img "a") >>= FG.write) \_data -> pure ()
  b <-
    FG.addPass
      g
      "B"
      (FG.read a >> (FG.create @Image "b" (img "b") >>= FG.write))
      \_data -> pure ()
  _ <-
    FG.addPass
      g
      "C"
      (FG.read b >> FG.create @Image "c" (img "c") >>= FG.write_ >> FG.setSideEffect)
      \_data -> pure ()
  FG.compile g
  s <- FG.snapshot g
  -- Entries in creation order (a, b, c); positions index the executing
  -- passes (A=0, B=1, C=2).
  map (.live) s.entries @?= [Just (0, 1), Just (1, 2), Just (2, 2)]
  -- 'a' dies at B and 'c' is born at C: they never coexist, so a backend
  -- owning the allocations could place them in the same memory.
  assertBool "a and c are aliasable" $
    case map (.live) s.entries of
      [Just (_, aEnd), _, Just (cStart, _)] -> aEnd < cStart
      _ -> False

dependencyLevels :: TestTree
dependencyLevels = testCase "dependency levels group the passes nothing orders" do
  g <- FG.newFrameGraph @Device @Device
  -- A and B produce independently, on different queues; C consumes both.
  a <- FG.addPass g "A" (FG.create @Image "a" (img "a") >>= FG.write) \_data -> pure ()
  b <-
    FG.addPass
      g
      "B"
      (FG.setQueue (QueueId 1) >> FG.create @Image "b" (img "b") >>= FG.write)
      \_data -> pure ()
  FG.addPass_ g "C" (FG.read a >> FG.read b >> FG.setSideEffect) (pure ())
  -- Culled: nobody reads its output and it claims no side effect.
  FG.addPass_ g "D" (void (FG.create @Image "d" (img "d") >>= FG.write)) (pure ())
  FG.compile g
  s <- FG.snapshot g
  -- A and B hold distinct execution positions (0 and 1) yet share a
  -- level: no edge orders them, so a backend may not read their
  -- positions as an ordering. C sits a level below both; D is culled.
  map (.level) s.passes @?= [Just 0, Just 0, Just 1, Nothing]

scratchCulledWithoutDemand :: TestTree
scratchCulledWithoutDemand = testCase "a scratch import's writer is culled without demand" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  scratch <- FG.importScratch g "S" (tex "S") (Tex 2)
  _ <- FG.addPass g "Fx" (FG.write scratch) \_h -> ranHere "Fx"
  s <- FG.snapshot g
  map (.sideEffect) s.passes @?= [False]
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev @?= []

scratchSurvivesOnDemand :: TestTree
scratchSurvivesOnDemand = testCase "a scratch import's writer survives on demand" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  scratch <- FG.importScratch g "S" (tex "S") (Tex 2)
  written <- FG.addPass g "Fx" (FG.write scratch) \_h -> ranHere "Fx"
  FG.addPass_ g "Probe" (FG.setSideEffect >> FG.read written) (ranHere "Probe")
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev @?= [ERun "Fx", ERun "Probe"]

renameCarriesFlags :: TestTree
renameCarriesFlags = testCase "pass B renames pass A's resource; flags reach the hooks" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  hA <-
    FG.addPass
      g
      "A"
      ( do
          h <- FG.create @Tex "R" (tex "R")
          FG.write h
      )
      \_data -> ranHere "A"
  hB <-
    FG.addPass
      g
      "B"
      ( do
          FG.readWith hA 7
          h' <- FG.writeWith hA 9
          FG.setSideEffect
          pure h'
      )
      \_data -> ranHere "B"
  FG.isValid g hA >>= \v -> v @?= False
  FG.isValid g hB >>= \v -> v @?= True
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev
    @?= [ ECreate "R" 0
        , ERun "A"
        , EPreRead "R" 7
        , EPreWrite "R" 9
        , ERun "B"
        , EDestroy "R"
        ]

emptyPassCulled :: TestTree
emptyPassCulled = testCase "a pass with no declarations and no side effect is culled" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  FG.addPass g "Nop" (pure ()) (\_data -> ranHere "Nop")
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev @?= []

chainExecutes :: TestTree
chainExecutes = testCase "multi-pass chain executes fully, unrelated pass is culled" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  backbuffer <- FG.importResource g "backbuffer" (tex "backbuffer") (Tex 42)
  hDepth <-
    FG.addPass
      g
      "Depth"
      ( do
          h <- FG.create @Tex "depth" (tex "depth")
          FG.write h
      )
      \_data -> ranHere "Depth"
  hGbuf <-
    FG.addPass
      g
      "GBuffer"
      ( do
          FG.read hDepth
          h <- FG.create @Tex "gbuf" (tex "gbuf")
          FG.write h
      )
      \_data -> ranHere "GBuffer"
  _ <-
    FG.addPass
      g
      "Lighting"
      ( do
          FG.read hGbuf
          FG.write backbuffer
      )
      \_data -> ranHere "Lighting"
  _ <-
    FG.addPass
      g
      "Orphan"
      ( do
          h <- FG.create @Tex "scratch" (tex "scratch")
          FG.write h
      )
      \_data -> ranHere "Orphan"
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev
    @?= [ ECreate "depth" 0
        , ERun "Depth"
        , ECreate "gbuf" 1
        , ERun "GBuffer"
        , EDestroy "depth"
        , ERun "Lighting"
        , EDestroy "gbuf"
        ]

cullingIsTransitive :: TestTree
cullingIsTransitive = testCase "culling is transitive through renamed versions" do
  -- A writes v1, B renames it to v2, nobody reads v2: both die.
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  hA <-
    FG.addPass
      g
      "A"
      ( do
          h <- FG.create @Tex "R" (tex "R")
          FG.write h
      )
      \_data -> ranHere "A"
  _ <-
    FG.addPass
      g
      "B"
      (FG.write hA)
      \_data -> ranHere "B"
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev @?= []
  s <- FG.snapshot g
  map (.canExecute) s.passes @?= [False, False]

creatorSurvivesBareRead :: TestTree
creatorSurvivesBareRead = testCase "a creator pass survives when only its created version is read" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  h <-
    FG.addPass
      g
      "Author"
      (FG.create @Tex "R" (tex "R"))
      \_data -> ranHere "Author"
  FG.addPass_
    g
    "Reader"
    do
      FG.read h
      FG.setSideEffect
    (ranHere "Reader")
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev @?= [ECreate "R" 0, ERun "Author", ERun "Reader", EDestroy "R"]

sideEffectKeepsInputAlive :: TestTree
sideEffectKeepsInputAlive = testCase "a side-effecting pass with zero refCount keeps its input alive" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  hA <-
    FG.addPass
      g
      "A"
      ( do
          h <- FG.create @Tex "R" (tex "R")
          FG.write h
      )
      \_data -> ranHere "A"
  _ <-
    FG.addPass
      g
      "ReadOnly"
      ( do
          FG.read hA
          FG.setSideEffect
      )
      \_data -> ranHere "ReadOnly"
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  -- ReadOnly executes despite its zero refCount, so R must outlive it
  -- (deliberately deeper than spec 4.3, which computes lifetimes over
  -- refCount > 0 passes only and would destroy R right after A).
  ev @?= [ECreate "R" 0, ERun "A", ERun "ReadOnly", EDestroy "R"]

execHooksBracketCallback :: TestTree
execHooksBracketCallback = testCase "exec hooks bracket the callback after the access hooks, composing in installation order" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  FG.addPreExec g \env' -> push env' (EFlush "adapter")
  FG.addPreExec g \env' -> push env' (EFlush "app")
  FG.addPostExec g \env' -> push env' (EPostFlush "adapter")
  FG.addPostExec g \env' -> push env' (EPostFlush "app")
  h <- FG.importResource g "R" (tex "R") (Tex 1)
  FG.addPass_
    g
    "P"
    ( do
        FG.readWith h 3
        FG.setSideEffect
    )
    (ranHere "P")
  FG.compile g
  FG.execute g env env
  ev <- getEvents env
  ev
    @?= [ EPreRead "R" 3
        , EFlush "adapter"
        , EFlush "app"
        , ERun "P"
        , EPostFlush "adapter"
        , EPostFlush "app"
        ]

sinkPassComposes :: TestTree
sinkPassComposes = testCase "addPass_ and write_ compose a sink pass with zero discards" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  h <- FG.importResource g "BB" (tex "BB") (Tex 1)
  FG.addPass_
    g
    "Present"
    (FG.writeWith_ h 6)
    (ranHere "Present")
  FG.compile g
  s <- FG.snapshot g
  -- writeWith_ renames like writeWith; the import still forces the
  -- side effect.
  FG.isValid g h >>= (@?= False)
  map (.sideEffect) s.passes @?= [True]
  FG.execute g env env
  ev <- getEvents env
  ev @?= [EPreWrite "BB" 6, ERun "Present"]

finalizeKeepsChainAlive :: TestTree
finalizeKeepsChainAlive = testCase "finalize keeps the chain alive and fires the terminal write hook" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  h <-
    FG.addPass
      g
      "A"
      (FG.create @Tex "R" (tex "R") >>= FG.write)
      \_data -> ranHere "A"
  FG.finalize g h 8
  FG.compile g
  s <- FG.snapshot g
  [fin] <- pure (filter (\p -> p.name == "finalize R") s.passes)
  fin.sideEffect @?= True
  FG.execute g env env
  ev <- getEvents env
  ev @?= [ECreate "R" 0, ERun "A", EPreWrite "R" 8, EDestroy "R"]