benchmarking

agora-bench/Bench.hs

@@ -1,12 +1,24 @@
-module Bench (Benchmark (..), benchmarkSize) where
+module Bench (Benchmark (..), benchmarkScript, specificationTreeToBenchmarks) where
 
 import Codec.Serialise (serialise)
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Short qualified as SBS
-import Data.Set (Set)
-import Data.Set qualified as Set
-import Data.Text (Text)
-import Plutus.V1.Ledger.Scripts qualified as Plutus
+import Data.List (intercalate)
+import Data.Maybe (fromJust)
+import Data.Text (Text, pack)
+import Plutus.V1.Ledger.Api (
+  ExBudget (ExBudget),
+  ExCPU,
+  ExMemory,
+  Script,
+ )
+import Plutus.V1.Ledger.Api qualified as Plutus
+
+import Spec.Spec (
+  Specification (Specification),
+  SpecificationExpectation (Success),
+  SpecificationTree (..),
+ )
 
 --------------------------------------------------------------------------------
 
@@ -14,20 +26,35 @@ import Plutus.V1.Ledger.Scripts qualified as Plutus
 data Benchmark = Benchmark
   { name :: Text
   -- ^ Human readable name describing script.
-  , size :: Int
+  , bCPUBudget :: ExCPU
+  -- ^ The on-chain execution cost of a script.
+  , bMemoryBudget :: ExMemory
+  -- ^ The on-chain memory budget of a script.
+  , bScriptSize :: Int
   -- ^ The on-chain size of a script.
   }
   deriving stock (Show, Eq, Ord)
 
--- | Create a benchmark containing only the size of the script.
-benchmarkSize :: Text -> Plutus.Script -> Set Benchmark
-benchmarkSize name script =
-  Set.singleton $
-    Benchmark
-      { name = name
-      , size = scriptSize script
-      }
+benchmarkScript :: String -> Script -> Benchmark
+benchmarkScript name script = Benchmark (pack name) cpu mem size
+  where
+    (ExBudget cpu mem) = evalScriptCounting . serialiseScriptShort $ script
+    size = SBS.length . SBS.toShort . LBS.toStrict . serialise $ script
 
--- | Compute the size of a script on-chain.
-scriptSize :: Plutus.Script -> Int
-scriptSize = SBS.length . SBS.toShort . LBS.toStrict . serialise
+    serialiseScriptShort :: Script -> SBS.ShortByteString
+    serialiseScriptShort = SBS.toShort . LBS.toStrict . serialise -- Using `flat` here breaks `evalScriptCounting`
+    evalScriptCounting :: Plutus.SerializedScript -> Plutus.ExBudget
+    evalScriptCounting script =
+      let costModel = fromJust Plutus.defaultCostModelParams
+          (_logout, e) = Plutus.evaluateScriptCounting Plutus.Verbose costModel script []
+       in case e of
+            Left evalError -> error ("Eval Error: " <> show evalError)
+            Right exbudget -> exbudget
+
+specificationTreeToBenchmarks :: SpecificationTree -> [Benchmark]
+specificationTreeToBenchmarks = go []
+  where
+    go names (Terminal ((Specification n ex s))) = case ex of
+      Success -> [benchmarkScript (intercalate "/" (names <> [n])) s]
+      _ -> []
+    go names (Group gn tree) = mconcat $ go (names <> [gn]) <$> tree

agora-bench/Main.hs

@@ -1,42 +1,33 @@
 module Main (main) where
 
-import Agora.AuthorityToken (authorityTokenPolicy)
-import Agora.Effect.TreasuryWithdrawal (treasuryWithdrawalValidator)
-import Agora.Governor (Governor (..))
-import Agora.Governor.Scripts (governorPolicy, governorValidator)
-import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
-import Agora.Stake.Scripts (stakePolicy, stakeValidator)
-import Agora.Treasury (treasuryValidator)
-import Bench
-import Data.Foldable (for_)
-import Plutus.V1.Ledger.Api (CurrencySymbol)
-import Sample.Shared
+import Bench (specificationTreeToBenchmarks)
+import Spec.AuthorityToken qualified as AuthorityToken
+import Spec.Effect.GovernorMutation qualified as GovernorMutation
+import Spec.Effect.TreasuryWithdrawal qualified as TreasuryWithdrawal
+import Spec.Governor qualified as Governor
+import Spec.Proposal qualified as Proposal
+import Spec.Spec (group)
+import Spec.Stake qualified as Stake
+import Spec.Treasury qualified as Treasury
 import Prelude
 
 --------------------------------------------------------------------------------
 
 main :: IO ()
 main = do
-  let benchmarks =
-        mconcat
-          [ -- GATs
-            benchmarkSize "authorityTokenPolicy" $ compile $ authorityTokenPolicy authorityToken
-          , -- Governor
-            benchmarkSize "governorValidator" $ compile $ governorValidator governor
-          , benchmarkSize "governorPolicy" $ compile $ governorPolicy governor
-          , -- Stake
-            benchmarkSize "stakeValidator" $ compile $ stakeValidator stake
-          , benchmarkSize "stakePolicy" $ compile $ stakePolicy governor.gtClassRef
-          , -- Proposal
-            benchmarkSize "proposalValidator" $ compile $ proposalValidator proposal
-          , benchmarkSize "proposalPolicy" $ compile $ proposalPolicy govAssetClass
-          , -- Treasury
-            benchmarkSize "treasuryValidator" $ compile $ treasuryValidator gatCS
-          , -- Effect validators
-            benchmarkSize "treasuryWithdrawalValidator" $ compile $ treasuryWithdrawalValidator gatCS
+  mapM_ print $
+    specificationTreeToBenchmarks $
+      group
+        "Benchmark"
+        [ group
+            "Effects"
+            [ group "Treasury Withdrawal Effect" TreasuryWithdrawal.specs
+            , group "Governor Mutation Effect" GovernorMutation.specs
+            ]
+        , group "Stake" Stake.specs
+        , group "Proposal" Proposal.specs
+        , group "AuthorityToken" AuthorityToken.specs
+        , group "Treasury" Treasury.specs
+        , group "AuthorityToken" AuthorityToken.specs
+        , group "Governor" Governor.specs
         ]
-
-  for_ benchmarks print
-
-gatCS :: CurrencySymbol
-gatCS = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049" -- arbitrary CS

agora.cabal

@@ -217,6 +217,7 @@ benchmark agora-bench
   build-depends:
     , agora
     , agora-sample
+    , agora-spec
 
 executable agora-scripts
   import:         lang, deps, exe-opts