Merge pull request #29 from Plutonomicon:srid/emulator-bench

Calculate budget/size for emulator trace

bench/Bench.hs

@@ -2,27 +2,31 @@ module Main (main) where
 
 import Criterion.Main
 import Criterion.Types
+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 qualified as Run
 
--- TODO: placeholder only for https://github.com/Plutonomicon/pluton/issues/9
---
--- We should add eDSL examples, and benchmark them here. The evaluator can
--- exposed from Plutarch (or it can be copied here).
-fib :: Int -> Int
-fib m
-  | m < 0 = error "negative!"
-  | otherwise = go m
-  where
-    go 0 = 0
-    go 1 = 1
-    go n = go (n -1) + go (n -2)
-
 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
+
+-- TODO: remove this after https://github.com/Plutonomicon/pluton/issues/26
+placeholder :: IO ()
+placeholder = do
   defaultMainWith
     cfg
     [ bgroup
@@ -42,9 +46,11 @@ main = do
           csvFile = Just "bench.csv"
         }
 
-exampleContractGift :: IO ()
-exampleContractGift = do
-  putStrLn "\n== Sample contract - Gift: sizes (haskell; pluto; plutarch) == "
-  print $ Run.validatorSize Gift.haskellValidator
-  print $ Run.validatorSize Gift.plutoValidator
-  print $ Run.validatorSize Gift.plutarchValidator
+fib :: Int -> Int
+fib m
+  | m < 0 = error "negative!"
+  | otherwise = go m
+  where
+    go 0 = 0
+    go 1 = 1
+    go n = go (n -1) + go (n -2)

bin/bench

@@ -0,0 +1,4 @@
+#!/usr/bin/env bash
+set -xe
+
+ghcid --restart=pluton.cabal -c 'cabal repl perf' -T :main

bin/ghcid

@@ -1,4 +1,4 @@
 #!/usr/bin/env bash
 set -xe
 
-ghcid -c 'cabal repl pluton' -T Pluton.smoke
+ghcid --restart=pluton.cabal -c 'cabal repl pluton' -T Pluton.smoke

bin/test

@@ -1,4 +1,4 @@
 #!/usr/bin/env bash
 set -xe
 
-ghcid -c 'cabal repl spec' -T :main
+ghcid --restart=pluton.cabal -c 'cabal repl spec' -T :main

pluton.cabal

@@ -16,6 +16,7 @@ common common
     GADTs
     ImportQualifiedPost
     LambdaCase
+    NamedFieldPuns
     OverloadedStrings
     PolyKinds
     RankNTypes
@@ -52,8 +53,12 @@ library
     , cardano-api
     , cardano-ledger-alonzo
     , containers
+    , data-default
     , fin
+    , flat
+    , foldl
     , freer-extras
+    , freer-simple
     , hashable
     , hedgehog
     , lens
@@ -69,6 +74,7 @@ library
     , QuickCheck
     , serialise
     , shower
+    , streaming
     , tasty
     , tasty-hedgehog
     , tasty-quickcheck
@@ -153,8 +159,16 @@ benchmark perf
   main-is:        Bench.hs 
   build-depends:
     , base
+    , bytestring
     , criterion
+    , data-default
+    , flat
+    , foldl
+    , freer-simple
     , pluton
     , pluton-examples
     , plutus-contract
     , plutus-core
+    , plutus-ledger
+    , streaming
+    , text

src/Pluton/Run/ScriptSize.hs

@@ -1,19 +1,57 @@
 module Pluton.Run.ScriptSize
   ( scriptSize,
     validatorSize,
+    emulatorTraceSize,
   )
 where
 
 import Codec.Serialise (serialise)
 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.Default
+import Data.Int (Int64)
 import Data.Maybe (fromJust)
+import Data.Monoid (Sum (..))
+import Flat (flat)
 import GHC.Stack (HasCallStack)
-import Ledger.Scripts (Script, Validator)
+import Ledger.Index (ExBudget, ScriptValidationEvent (..), ValidatorMode (FullyAppliedValidators), getScript)
+import Ledger.Scripts (Script (unScript), Validator)
+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)
 
--- (ExBudget {exBudgetCPU = ExCPU 327603, exBudgetMemory = ExMemory 1200},336)
+-- | Return the exbudget and script size of the 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.
+emulatorTraceSize :: Em.EmulatorTrace a -> (ExBudget, Sum Int64)
+emulatorTraceSize 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 . unScript . getScript mode $ event
+            byteSize = BSL.length bytes
+            exBudget = either (error . show) fst sveResult
+         in (exBudget, Sum byteSize)
+   in f . exactlyOne $ getEvents Folds.scriptEvents
+  where
+    exactlyOne :: [a] -> a
+    exactlyOne [x] = x
+    exactlyOne _ = error "benchEmulatorTrace: expected exactly one validator run"
 
 -- | Return the script size in bytes along with execution budget.
 validatorSize :: Validator -> (Plutus.ExBudget, Int)