phino-0.0.134: benchmark/Main.hs

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

module Main where

import AST (Expression (ExRoot), hashExpression)
import CLI.Helpers (started)
import Control.Exception (evaluate)
import Control.Monad (replicateM, replicateM_)
import qualified Data.Map.Strict as Map
import Data.Time.Clock
import Dataize (reduction)
import Deps (Judgment (Morphing), dontSaveEval, dontSaveStep)
import Encoding (Encoding (UNICODE))
import Evaluate (evaluation, fired)
import Functions (buildTerm)
import Lambdas (Lambdas, readLambdas)
import Lining (LineFormat (MULTILINE, SINGLELINE))
import Margin (defaultMargin)
import Merge (merge)
import Morph (ReduceContext (ReduceContext), Steps (Steps), morph)
import Must (Must (MtDisabled))
import Parser (parseExpressionThrows)
import Printer (printExpression')
import Rewriter (RewriteContext (RewriteContext), rewrite)
import Sugar (SugarType (SALTY, SWEET))
import Tau (seedTaus)
import Text.Printf (printf)
import XMIR (parseXMIRThrows, xmirToPhi)
import Yaml (normalizationRules)

warmups :: Int
warmups = 3

iterations :: Int
iterations = 10

targetBatchMs :: Double
targetBatchMs = 20.0

-- The wall-clock, in microseconds, one case may spend on its warmups and its
-- measured batches together. Every case that only parses, prints or rewrites
-- runs in microseconds and batches up to the window above, so ten batches of
-- it cost a fraction of a second and the budget never binds. A symbolic
-- morphing takes whole seconds per run, and inside a world the size of
-- 'native.phi' tens of them, so three warmups plus ten batches of one would
-- outlast the jobs the workflows run the suite in — 'regression-check' runs
-- the whole binary ten times over, once per round per side. The warmups and
-- the iterations are therefore cut to what the budget affords, never below one
-- measured batch, so an expensive case still reports the same lines as every
-- other one.
budget :: Double
budget = 30.0 * 1e6

rewriteCtx :: RewriteContext
rewriteCtx =
  RewriteContext
    ExRoot
    100
    100
    False
    Nothing
    buildTerm
    MtDisabled
    Nothing
    dontSaveStep

-- The step budget, the rewriting bounds and the flags the symbolic cases morph
-- with, which are the defaults of the 'morph' command plus the three switches
-- the regression was seen under: '--deep', so a λ function standing anywhere
-- inside the term is fired and not only the one on the spine; '--acyclic', so
-- a term coming back to itself parks instead of spending the whole step
-- budget; and '--partial', so a λ function no entry answers parks too and the
-- run still reaches an answer to measure. Nothing is written anywhere: the
-- protocol of '--protocol' and the steps of '--steps-dir' are files, and a
-- benchmark measuring the calculus has no business measuring the disk.
symbolicCtx :: Lambdas -> Expression -> ReduceContext
symbolicCtx lambdas locator =
  ReduceContext
    locator -- _locator
    locator -- _site
    Nothing -- _universe
    25 -- _maxDepth
    25 -- _maxCycles
    (Steps 1000 0) -- _steps
    1 -- _nesting
    False -- _depthSensitive
    False -- _shuffle
    True -- _partial
    True -- _deep
    True -- _acyclic
    Morphing -- _judgment
    [] -- _parked
    Map.empty -- _seen
    Map.empty -- _dataized
    lambdas -- _symbolic
    buildTerm -- _buildTerm
    reduction -- _reduce
    evaluation -- _evaluate
    fired -- _fire
    dontSaveStep -- _saveStep
    dontSaveEval -- _saveEval

timeAction :: IO a -> IO Double
timeAction action = do
  start <- getCurrentTime
  _ <- evaluate =<< action
  end <- getCurrentTime
  pure (realToFrac (diffUTCTime end start) * 1e6)

timeBatch :: Int -> IO a -> IO Double
timeBatch batch action = do
  start <- getCurrentTime
  replicateM_ batch (evaluate =<< action)
  end <- getCurrentTime
  pure (realToFrac (diffUTCTime end start) * 1e6 / fromIntegral batch)

stdDev :: [Double] -> Double -> Double
stdDev xs avg = sqrt (sum (map (\x -> (x - avg) ^ (2 :: Int)) xs) / fromIntegral (length xs))

runBench :: String -> IO a -> IO ()
runBench name action = do
  single <- timeAction action
  let batch = max 1 (round (targetBatchMs * 1000.0 / single))
      afford = max 1 (floor (budget / (single * fromIntegral batch)) :: Int)
      warms = max 0 (min warmups (afford `div` 3))
      iters = max 1 (min iterations (afford - warms))
  replicateM_ warms action
  times <- replicateM iters (timeBatch batch action)
  let total = sum times * fromIntegral batch
      avg = sum times / fromIntegral iters
      mn = minimum times
      mx = maximum times
      sd = stdDev times avg
  putStrLn $ "=== " ++ name ++ " ==="
  putStrLn $ printf "  warmup:     %d iterations" warms
  putStrLn $ printf "  batches:    %d x %d" iters batch
  putStrLn $ printf "  total:      %.3f μs" total
  putStrLn $ printf "  avg:        %.3f μs" avg
  putStrLn $ printf "  min:        %.3f μs" mn
  putStrLn $ printf "  max:        %.3f μs" mx
  putStrLn $ printf "  std dev:    %.3f μs" sd

main :: IO ()
main = do
  src <- readFile "benchmark/tmp/native.phi"
  xsrc <- readFile "benchmark/tmp/Native.xmir"
  dsrc <- readFile "benchmark/demo.phi"
  expr <- parseExpressionThrows src
  demo <- parseExpressionThrows dsrc
  merged <- merge [demo, expr]
  lambdas <- readLambdas "benchmark/atoms.yaml"
  runBench "parse/phi" (parseExpressionThrows src)
  runBench "parse/xmir" (parseXMIRThrows xsrc >>= xmirToPhi)
  runBench "rewrite/normalize" (rewrite expr normalizationRules rewriteCtx)
  runBench
    "print/sweet/multiline"
    (evaluate (length (printExpression' expr (SWEET, UNICODE, MULTILINE, defaultMargin))))
  runBench
    "print/sweet/flat"
    (evaluate (length (printExpression' expr (SWEET, UNICODE, SINGLELINE, defaultMargin))))
  runBench
    "print/salty/multiline"
    (evaluate (length (printExpression' expr (SALTY, UNICODE, MULTILINE, defaultMargin))))
  mapM_ (aimed "demo" demo lambdas) entries
  aimed "native" merged lambdas probe
  where
    -- The entries of the demo world, each one term the λ functions of
    -- 'benchmark/atoms.yaml' answer and each one case of the suite, so that a
    -- slowdown of one of them is a line of its own rather than a share of a
    -- single total.
    entries :: [String]
    entries = ["e1", "e2", "e3", "e4", "e5"]
    -- The one entry timed inside 'native.phi' as well, whose two numbers say
    -- between them what the world around an entry costs — the very comparison
    -- nothing in the suite used to make, and the one 'number.neg' was seen to
    -- lose two orders of magnitude on (#1291). It is the smallest entry of the
    -- demo world, a single λ function fired against one unknown, because the
    -- cost measured here is the world's and not the term's: the bigger entries
    -- pay the same price per firing and merely pay it more often, which inside
    -- a megabyte of 'native.phi' is more than a benchmark can wait for.
    probe :: String
    probe = "e5"
    -- One case of the symbolic suite: the entry of the demo world 𝕄 is aimed
    -- at, inside the world it is aimed in.
    aimed :: String -> Expression -> Lambdas -> String -> IO ()
    aimed label universe lambdas name = do
      locator <- parseExpressionThrows ("Φ.l🌵." ++ name)
      runBench (printf "morph/symbolic/%s/%s" label name) (symbolic universe lambdas locator)
    -- One symbolic morphing of one entry, the way the 'morph' command runs it:
    -- the 𝜏-labels of the universe are scanned once, the run starts from the
    -- state that world already carries and 𝕄 is aimed at the entry. The answer
    -- is hashed rather than merely forced to weak head normal form, since a
    -- term left as a thunk is work the benchmark asked for and did not wait
    -- for.
    symbolic :: Expression -> Lambdas -> Expression -> IO Int
    symbolic universe lambdas locator = do
      seedTaus universe
      (answer, _, _) <- morph universe (started universe) (symbolicCtx lambdas locator)
      pure (hashExpression answer)