fragr-0.1.0.0: bench/Bench.hs

{-# LANGUAGE TypeFamilies #-}

{-| tasty-bench benchmarks: whole-frame build/compile/execute cycles, since
a frame graph is a single-use object.
-}
module Main (main) where

import Control.Monad (foldM)
import Data.Text (Text)
import Data.Text qualified as Text
import Test.Tasty.Bench (bench, bgroup, defaultMain, whnfIO)

import Fragr (Handle)
import Fragr qualified as FG

data Buffer = Buffer

instance FG.Resource Buffer where
  type Desc Buffer = Int
  type Alloc Buffer = ()
  type Ctx Buffer = ()
  createResource _ () = pure Buffer
  destroyResource _ () _ = pure ()

main :: IO ()
main =
  defaultMain
    [ bgroup
        "chain (build+compile+execute)"
        [ bench "10" $ whnfIO (chain 10)
        , bench "100" $ whnfIO (chain 100)
        , bench "1000" $ whnfIO (chain 1000)
        ]
    , bgroup
        "culled (build+compile)"
        [ bench "100" $ whnfIO (culled 100)
        , bench "1000" $ whnfIO (culled 1000)
        ]
    , bgroup
        "fan-out (build+compile+execute)"
        [ bench "100" $ whnfIO (fanOut 100)
        , bench "1000" $ whnfIO (fanOut 1000)
        ]
    ]

{- | A linear chain: every pass reads its predecessor's output and writes a
fresh resource of its own; the last pass has a side effect, so the whole
chain survives culling and executes.
-}
chain :: Int -> IO ()
chain n = do
  g <- FG.newFrameGraph
  h0 <- producer g 0
  hLast <-
    foldM
      ( \prev i ->
          FG.addPass
            g
            (passName i)
            do
              FG.read prev
              h <- FG.create @Buffer (bufName i) i
              FG.write h
            \_data -> pure ()
      )
      h0
      [1 .. n - 1]
  FG.addPass_
    g
    "present"
    do
      FG.read hLast
      FG.setSideEffect
    (pure ())
  FG.compile g
  FG.execute g () ()

-- | N independent passes whose outputs nobody reads: all culled.
culled :: Int -> IO ()
culled n = do
  g <- FG.newFrameGraph
  mapM_ (producer g) [0 .. n - 1]
  FG.compile g

-- | One producer, N side-effecting readers.
fanOut :: Int -> IO ()
fanOut n = do
  g <- FG.newFrameGraph
  h <- producer g 0
  mapM_
    ( \i ->
        FG.addPass_
          g
          (passName i)
          do
            FG.read h
            FG.setSideEffect
          (pure ())
    )
    [1 .. n]
  FG.compile g
  FG.execute g () ()

producer :: FG.FrameGraph () () -> Int -> IO (Handle Buffer)
producer g i =
  FG.addPass
    g
    (passName i)
    do
      h <- FG.create @Buffer (bufName i) i
      FG.write h
    \_data -> pure ()

passName :: Int -> Text
passName i = "pass" <> Text.pack (show i)

bufName :: Int -> Text
bufName i = "buf" <> Text.pack (show i)