Report and write .csv of validator benchmarks

README.md

@@ -43,13 +43,13 @@ cabal run pluton
 
 ## Benchmarks
 
-Note: Benchmarks are not implemented yet. This is only a placeholder.
+Note: Benchmarks are work in progress; we intend to benchmark all examples in CI.
 
 ```
 cabal bench
 ```
 
-This will write the benchmark report to `report.html`.
+This will write the benchmark report to `bench.*`.
 
 ### Benchmarking a commit
 

bench/Bench.hs

@@ -1,29 +1,51 @@
+{-# LANGUAGE RecordWildCards #-}
+
 module Main (main) where
 
+import Control.Monad.Writer (MonadWriter, execWriterT, tell)
 import Criterion.Main
 import Criterion.Types
+import Data.ByteString.Lazy qualified as BSL
+import Data.Csv qualified as Csv
+import Data.List qualified as List
 import Example.Contract.Gift.Test qualified as GiftTest
 import Example.Contract.Gift.Validator.Haskell qualified as Gift
 import Example.Contract.Gift.Validator.Plutarch qualified as Gift
 import Example.Contract.Gift.Validator.Pluto qualified as Gift
+import Pluton.Run (Budget (..))
 import Pluton.Run qualified as Run
+import Text.PrettyPrint.Boxes qualified as B
 
 main :: IO ()
 main = do
   exampleContractGift
-  placeholder
 
 exampleContractGift :: IO ()
 exampleContractGift = do
-  putStrLn "\n== Sample contract - Gift: sizes (haskell; pluto; plutarch) == "
-  print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.haskellValidator)
-  print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutoValidator)
-  print $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutarchValidator)
+  putStrLn "== Examples / Contract / Gift == "
+  budgets <- execWriterT $ do
+    let k = "examples:contract:gift:"
+    reportBudget (k <> "haskell") $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.haskellValidator)
+    reportBudget (k <> "pluto") $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutoValidator)
+    reportBudget (k <> "plutarch") $ Run.emulatorTraceBudget (GiftTest.smokeTrace Gift.plutarchValidator)
+  let csv = Csv.encodeDefaultOrderedByName budgets
+  BSL.writeFile "bench.csv" csv
+  putStrLn "Wrote to bench.csv:"
+  putStrLn $ B.render $ renderNamedBudgets budgets
+
+reportBudget :: (MonadWriter [Run.NamedBudget] m) => String -> Budget -> m ()
+reportBudget name budget = do
+  -- liftIO $ putStrLn $ "\t[" <> name <> "]\t\t " <> show exBudgetCPU <> " " <> show exBudgetMemory <> " " <> show scriptSizeBytes
+  tell [Run.NamedBudget (name, budget)]
 
+renderNamedBudgets :: [Run.NamedBudget] -> B.Box
+renderNamedBudgets bs =
+  let cols = List.transpose $ [[name, show cpu, show mem, show sz] | Run.NamedBudget (name, Run.Budget cpu mem sz) <- bs]
+   in B.hsep 2 B.left . map (B.vcat B.left . map B.text) $ cols
 
 -- TODO: remove this after https://github.com/Plutonomicon/pluton/issues/26
-placeholder :: IO ()
-placeholder = do
+_placeholder :: IO ()
+_placeholder = do
   defaultMainWith
     cfg
     [ bgroup

exe/Main.hs

@@ -3,11 +3,8 @@
 module Main (main) where
 
 import Example.Contract.Gift.Test qualified as GiftTest
-import Example.Contract.Gift.Validator.Haskell qualified as Gift
 import Example.Contract.Gift.Validator.Plutarch qualified as Gift
-import Example.Contract.Gift.Validator.Pluto qualified as Gift
 import Pluton qualified
-import Pluton.Run qualified as Run
 import Plutus.Trace.Emulator qualified as Em
 
 main :: IO ()

flake.nix

@@ -137,7 +137,7 @@
         # We need to append the checks that come from haskell.nix to our own,
         # hence the need for flake.checks // {}.
         checks = flake.checks // {
-          benchmark = pkgs.runCommand "benchmark" {} "${self.apps.${system}.benchmark.program} | tee $out";
+          benchmark = pkgs.runCommand "benchmark" { } "${self.apps.${system}.benchmark.program} | tee $out";
         };
         ciNix = inputs.flake-compat-ci.lib.recurseIntoFlakeWith {
           flake = self;

pluton.cabal

@@ -37,8 +37,8 @@ library
   exposed-modules:
     Pluton
     Pluton.Run
-    Pluton.Run.Evaluate
     Pluton.Run.Budget
+    Pluton.Run.Evaluate
     Pluton.Types.Builtin
     Pluton.Types.Builtin.Data
     Pluton.Types.Builtin.Fun
@@ -52,6 +52,7 @@ library
     , bytestring
     , cardano-api
     , cardano-ledger-alonzo
+    , cassava
     , containers
     , data-default
     , fin
@@ -159,16 +160,16 @@ benchmark perf
   main-is:        Bench.hs 
   build-depends:
     , base
+    , boxes
     , bytestring
+    , cassava
     , criterion
     , data-default
-    , flat
     , foldl
-    , freer-simple
+    , mtl
     , pluton
     , pluton-examples
     , plutus-contract
     , plutus-core
     , plutus-ledger
-    , streaming
     , text

src/Pluton/Run/Budget.hs

@@ -1,6 +1,11 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+
 -- | Execution budget and script size for Plutus scripts
 module Pluton.Run.Budget
   ( Budget (..),
+    NamedBudget (..),
     -- | * Budget for an arbitraty Plutus script
     scriptBudget,
     -- | * Budget for EmulatorTrace
@@ -15,12 +20,22 @@ import Control.Monad.Freer qualified as Freer
 import Data.ByteString.Lazy qualified as BSL
 import Data.ByteString.Lazy qualified as LB
 import Data.ByteString.Short qualified as SBS
+import Data.Csv
+  ( DefaultOrdered (..),
+    ToField,
+    ToNamedRecord (..),
+    header,
+    namedRecord,
+    (.=),
+  )
 import Data.Default (Default (def))
 import Data.Int (Int64)
 import Data.Maybe (fromJust)
 import Flat (flat)
+import GHC.Generics
 import GHC.Stack (HasCallStack)
-import Ledger.Index (ExBudget, ScriptValidationEvent (..), ValidatorMode (FullyAppliedValidators), getScript)
+import Ledger (ExBudget (ExBudget))
+import Ledger.Index (ExCPU, ExMemory, ScriptValidationEvent (..), ValidatorMode (FullyAppliedValidators), getScript)
 import Ledger.Scripts (Script)
 import Ledger.Scripts qualified as Scripts
 import Plutus.Trace.Emulator qualified as Em
@@ -29,12 +44,6 @@ import Streaming.Prelude qualified as S
 import Wallet.Emulator.Folds qualified as Folds
 import Wallet.Emulator.Stream (foldEmulatorStreamM)
 
-data Budget = Budget
-  { exBudget :: ExBudget,
-    scriptSizeBytes :: Int64
-  }
-  deriving stock (Show)
-
 -- | Return the exbudget and script size of the *applied* validator run inside
 -- an Emulator trace.
 --
@@ -55,15 +64,15 @@ emulatorTraceBudget trace =
         let bytes = BSL.fromStrict . flat . Scripts.unScript . getScript mode $ event
             byteSize = BSL.length bytes
             exBudget = either (error . show) fst sveResult
-         in Budget exBudget byteSize
+         in mkBudget exBudget byteSize
    in f . exactlyOne $ getEvents Folds.scriptEvents
   where
     exactlyOne :: [a] -> a
     exactlyOne [x] = x
     exactlyOne _ = error "benchEmulatorTrace: expected exactly one validator run"
 
 scriptBudget :: Script -> Budget
-scriptBudget = uncurry Budget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseScript
+scriptBudget = uncurry mkBudget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseScript
 
 serialiseScript :: Script -> SBS.ShortByteString
 serialiseScript = SBS.toShort . LB.toStrict . Codec.serialise -- Using `flat` here breaks `evalScriptCounting`
@@ -75,3 +84,29 @@ evalScriptCounting script = do
    in case e of
         Left evalErr -> error ("Eval Error: " <> show evalErr)
         Right exbudget -> exbudget
+
+--- Types
+
+data Budget = Budget
+  { exBudgetCPU :: ExCPU,
+    exBudgetMemory :: ExMemory,
+    scriptSizeBytes :: ScriptSizeBytes
+  }
+  deriving stock (Show, Generic)
+
+newtype ScriptSizeBytes = ScriptSizeBytes Int64
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving newtype (Num, ToField)
+
+newtype NamedBudget = NamedBudget (String, Budget)
+  deriving stock (Show, Generic)
+
+instance ToNamedRecord NamedBudget where
+  toNamedRecord (NamedBudget (name, Budget {..})) =
+    namedRecord ["name" .= name, "cpu" .= exBudgetCPU, "mem" .= exBudgetMemory, "size" .= scriptSizeBytes]
+
+instance DefaultOrdered NamedBudget where
+  headerOrder _ = header ["name", "cpu", "mem", "size"]
+
+mkBudget :: ExBudget -> Int64 -> Budget
+mkBudget (ExBudget cpu mem) = Budget cpu mem . ScriptSizeBytes