Merge pull request #30 from Plutonomicon:srid/budget-report

Benchmark contract validators

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,32 +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.emulatorTraceSize (GiftTest.smokeTrace Gift.haskellValidator)
-  print $ Run.emulatorTraceSize (GiftTest.smokeTrace Gift.plutoValidator)
-  print $ Run.emulatorTraceSize (GiftTest.smokeTrace Gift.plutarchValidator)
-  putStrLn "=="
-  print $ Run.validatorSize Gift.haskellValidator
-  print $ Run.validatorSize Gift.plutoValidator
-  print $ Run.validatorSize 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,21 +3,14 @@
 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 ()
 main = do
   Pluton.smoke
   -- Gift contract example
-  putStrLn "\n== Sample contract - Gift: sizes (haskell; pluto; plutarch) == "
-  print $ Run.validatorSize Gift.haskellValidator
-  print $ Run.validatorSize Gift.plutoValidator
-  print $ Run.validatorSize Gift.plutarchValidator
   putStrLn "\n== Sample contract - Gift: emulator == "
   Em.runEmulatorTraceIO $ GiftTest.smokeTrace Gift.plutarchValidator
   putStrLn "\n== Sample contract - Gift: tests == "

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.Budget
     Pluton.Run.Evaluate
-    Pluton.Run.ScriptSize
     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.hs

@@ -35,7 +35,7 @@ smoke = do
   let eval :: ClosedTerm a -> IO ()
       eval p = do
         print $ Smoke.evalPlutarch p
-        print $ Run.scriptSize $ Run.compile p
+        print $ Run.scriptBudget $ Run.compile p
       fourtyTwo = 42 :: Term s PInteger
       intNil =
         Plutarch.punsafeConstant $

src/Pluton/Run.hs

@@ -1,4 +1,4 @@
 module Pluton.Run (module X) where
 
+import Pluton.Run.Budget as X
 import Pluton.Run.Evaluate as X
-import Pluton.Run.ScriptSize as X

src/Pluton/Run/Budget.hs

@@ -0,0 +1,112 @@
+{-# 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
+    emulatorTraceBudget,
+  )
+where
+
+import Codec.Serialise qualified as Codec
+import Control.Arrow ((&&&))
+import Control.Foldl qualified as Foldl
+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 (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
+import Plutus.V1.Ledger.Api qualified as Plutus
+import Streaming.Prelude qualified as S
+import Wallet.Emulator.Folds qualified as Folds
+import Wallet.Emulator.Stream (foldEmulatorStreamM)
+
+-- | Return the exbudget and script size of the *applied* validator run inside
+-- an Emulator trace.
+--
+-- The trace must have run the validation exactly once, else this will fail. We
+-- do this, because we are benchmarking a single run of the validator, not
+-- multiple runs.
+emulatorTraceBudget :: Em.EmulatorTrace a -> Budget
+emulatorTraceBudget trace =
+  -- Most of the code here is taken from `Plutus.Trace.Emulator.Extract` (IOHK
+  -- doesn't care to export it).
+  let stream = Em.runEmulatorStream def trace
+      getEvents :: Folds.EmulatorEventFold a -> a
+      getEvents theFold = S.fst' $ Freer.run $ foldEmulatorStreamM (Foldl.generalize theFold) stream
+      -- This gets us the fully applied validator script.
+      -- Note: This doesn't deal with minting policy scripts
+      mode = FullyAppliedValidators
+      f event@ScriptValidationEvent {sveResult} =
+        let bytes = BSL.fromStrict . flat . Scripts.unScript . getScript mode $ event
+            byteSize = BSL.length bytes
+            exBudget = either (error . show) fst sveResult
+         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 mkBudget . (evalScriptCounting &&& (fromInteger . toInteger . SBS.length)) . serialiseScript
+
+serialiseScript :: Script -> SBS.ShortByteString
+serialiseScript = SBS.toShort . LB.toStrict . Codec.serialise -- Using `flat` here breaks `evalScriptCounting`
+
+evalScriptCounting :: HasCallStack => Plutus.SerializedScript -> Plutus.ExBudget
+evalScriptCounting script = do
+  let costModel = fromJust Plutus.defaultCostModelParams
+      (_logout, e) = Plutus.evaluateScriptCounting Plutus.Verbose costModel script []
+   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