tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

Bench.hs (5381B)

      1 module Main where
      2 
      3 import Control.Exception (evaluate)
      4 import Control.Monad (forM_, unless)
      5 import Criterion.Main
      6 import Crypto.Hash (hash, Digest, SHA256)
      7 import Runtime
      8 import TreeObservation (forceTreeShared)
      9 import Wire
     10 import qualified Data.ByteString as BS
     11 import qualified Data.Map as Map
     12 import qualified Data.Text as Text
     13 import qualified Data.Vector as V
     14 import System.Environment (getArgs, withArgs)
     15 import System.Exit (die)
     16 import System.Timeout (timeout)
     17 
     18 -- Runtime inputs and complete expectations are independent of worker compilation.
     19 -- These replace the historical parsing/evaluation timings, not reproduce them.
     20 cases :: [(String, String, T, T)]
     21 cases =
     22   [ ("unchecked head", "uncheckedHead", numbers [1..5], ofNumber 1)
     23   , ("head (explicit check)", "checkedHead", numbers [1..5], ok (ofNumber 1))
     24   , ("div (library guards)", "guardedDiv", ofNumber 2, ofNumber 5)
     25   , ("div (nonzero boundary)", "checkedDiv", ofNumber 2, ok (ofNumber 5))
     26   , ("div failure (zero boundary)", "checkedDiv", Leaf, err "non-zero")
     27   , ("sorted maximum", "sortedMaximum", numbers [1..5], ok (ofNumber 5))
     28   , ("half (even boundary)", "evenHalf", ofNumber 8, ok (ofNumber 4))
     29   , ("sortedList? success", "sortedSum", numbers [1..5], ok (ofNumber 15))
     30   , ("sortedList? failure", "sortedSum", numbers [5,1,3], err "not sorted")
     31   , ("listOf nat? success", "naturalSum", numbers [1..5], ok (ofNumber 15))
     32   , ("fn2 apply add", "checkedAdd", ofNumber 3, ok (ofNumber 8))
     33   , ("fnContract apply identity", "checkedIdentity", ofNumber 7, ok (ofNumber 7))
     34   ]
     35   where
     36     numbers = ofList . map ofNumber
     37     ok value = Fork (Stem Leaf) (Fork value Leaf)
     38     err message = Fork Leaf (Fork (ofString message) Leaf)
     39 
     40 -- The runtime argument remains outside the timed closure. Observing this Bool
     41 -- demands the entire expected canonical result, rather than only its outer tag.
     42 {-# NOINLINE observeResult #-}
     43 observeResult :: T -> T -> T -> Bool
     44 observeResult worker expected input = apply worker input == expected
     45 
     46 loadWorkers :: FilePath -> String -> IO Env
     47 loadWorkers path expected = do
     48   unless (length expected == 64 && all (`elem` ("0123456789abcdef" :: String)) expected) $
     49     die "expected a lowercase whole-bundle SHA256"
     50   bytes <- BS.readFile path
     51   unless (show (hash bytes :: Digest SHA256) == expected) $ die "worker bundle SHA256 mismatch"
     52   bundle <- either die pure (decodeBundle bytes)
     53   either die pure (verifyBundle bundle)
     54   let terms = reconstructBundleTerms (bundleNodes bundle)
     55       entries = manifestExports (bundleManifest bundle)
     56       env = Map.fromList [(Text.unpack (exportName entry), terms V.! fromIntegral (exportRoot entry)) | entry <- entries]
     57       wanted = Map.fromList [(name, ()) | (_, name, _, _) <- cases] `Map.union`
     58         Map.fromList [(name, ()) | name <- ["uncheckedHash", "inlineHash", "contractHash"]]
     59   unless (Map.size env == length entries && Map.keysSet env == Map.keysSet wanted) $
     60     die "worker bundle must have exactly the benchmark export interface"
     61   -- Loaded trees are inert/shared. Fully construct all workers before timing.
     62   mapM_ forceTreeShared (Map.elems env)
     63   pure env
     64 
     65 prepare :: Env -> IO [Benchmark]
     66 prepare env = do
     67   let worker name = env Map.! name
     68       valid = concat (replicate 4 "0123456789abcdef")
     69       inputs =
     70         [ ("valid", ofString valid, True)
     71         , ("invalid-first", ofString ('g' : tail valid), False)
     72         , ("invalid-last", ofString (take 63 valid ++ "g"), False)
     73         , ("oversized-65", ofString (replicate 65 'a'), False)
     74         , ("oversized-65536", ofString (replicate 65536 'a'), False)
     75         ]
     76       hashWorkers = [("unchecked", "uncheckedHash"), ("inline", "inlineHash"), ("contract", "contractHash")]
     77       expectedHash name validInput = if name == "unchecked" || validInput then Stem Leaf else Leaf
     78   forM_ cases $ \(label, name, input, expected) -> do
     79     forceTreeShared input
     80     forceTreeShared expected
     81     validCase <- evaluate (observeResult (worker name) expected input)
     82     unless validCase $ die ("invalid contract benchmark: " ++ label)
     83   forM_ inputs $ \(_, input, expected) -> do
     84     forceTreeShared input
     85     forM_ hashWorkers $ \(label, name) -> do
     86       validCase <- evaluate (observeResult (worker name) (expectedHash label expected) input)
     87       unless validCase $ die ("invalid registry boundary benchmark: " ++ label)
     88   pure
     89     [ bgroup "contracts"
     90         [ bench label $ whnf (observeResult (worker name) expected) input
     91         | (label, name, input, expected) <- cases ]
     92     , bgroup "registry-hash"
     93         [ bgroup label
     94             [ bench workerLabel $ whnf (observeResult (worker name) (expectedHash workerLabel expected)) input
     95             | (workerLabel, name) <- hashWorkers ]
     96         | (label, input, expected) <- inputs ]
     97     ]
     98 
     99 main :: IO ()
    100 main = do
    101   args <- getArgs
    102   case args of
    103     path : digest : criterionArgs -> do
    104       prepared <- timeout (120 * 1000000) (loadWorkers path digest >>= prepare)
    105       benchmarks <- maybe (die "benchmark loading/validation exceeded 120 seconds") pure prepared
    106       putStrLn ("Worker bundle SHA256: " ++ digest)
    107       if criterionArgs == ["--verify-only"]
    108         then putStrLn "All 27 benchmark cases validated; no timings collected."
    109         else withArgs criterionArgs (defaultMain benchmarks)
    110     _ -> die "usage: tricu-bench WORKERS.arboricx SHA256 [--verify-only | CRITERION_OPTIONS]"