PLT-901: Implement some basic benchmarks for script context usage (IntersectMBO#4941)

* PLT-901: Implement some basic benchmarks for script context usage

Two cases:
1. Decode the script context and do some comparable work
2. Decode the script context then ignore it and do something cheap

Both run with a couple of different sizes of script context. This should
show some significant changes with the sums and products work.

* Comment

Author: michaelpj

.stylish-haskell.yaml

@@ -25,6 +25,7 @@ language_extensions:
   - GeneralizedNewtypeDeriving
   - MultiParamTypeClasses
   - NamedFieldPuns
+  - ImportQualifiedPost
   - PackageImports
   - QuasiQuotes
   - ScopedTypeVariables

plutus-benchmark/plutus-benchmark.cabal

@@ -357,3 +357,41 @@ executable ed25519-throughput
     , plutus-core           ^>=1.1
     , plutus-tx             ^>=1.1
     , plutus-tx-plugin      ^>=1.1
+
+---------------- script contexts ----------------
+
+library script-contexts-internal
+  import:          lang
+
+  if impl(ghc <9.0)
+    buildable: False
+
+  -- Something weird causes this to sometimes report
+  -- the plugin package as unused...
+  ghc-options:     -Wno-unused-packages
+  hs-source-dirs:  script-contexts/src
+  exposed-modules: PlutusBenchmark.ScriptContexts
+  build-depends:
+    , base               >=4.9 && <5
+    , plutus-ledger-api  ^>=1.1
+    , plutus-tx          ^>=1.1
+    , plutus-tx-plugin   ^>=1.1
+
+test-suite plutus-benchmark-script-contexts-tests
+  import:         lang
+
+  if impl(ghc <9.0)
+    buildable: False
+
+  type:           exitcode-stdio-1.0
+  main-is:        Spec.hs
+  hs-source-dirs: script-contexts/test
+  other-modules:
+  build-depends:
+    , base                                            >=4.9 && <5
+    , plutus-benchmark-common
+    , plutus-core:{plutus-core, plutus-core-testlib}  ^>=1.1
+    , plutus-tx:{plutus-tx, plutus-tx-testlib}        ^>=1.1
+    , script-contexts-internal
+    , tasty
+    , tasty-hunit

plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+module PlutusBenchmark.ScriptContexts where
+
+import PlutusLedgerApi.V1
+import PlutusLedgerApi.V1.Address
+import PlutusLedgerApi.V1.Value
+import PlutusTx qualified as PlutusTx
+import PlutusTx.Builtins qualified as PlutusTx
+import PlutusTx.Prelude qualified as PlutusTx
+
+-- | A very crude deterministic generator for 'ScriptContext's with size
+-- approximately proportional to the input integer.
+mkScriptContext :: Int -> ScriptContext
+mkScriptContext i = ScriptContext (mkTxInfo i) (Spending (TxOutRef (TxId "") 0))
+
+mkTxInfo :: Int -> TxInfo
+mkTxInfo i = TxInfo {
+  txInfoInputs=mempty,
+  txInfoOutputs=fmap mkTxOut [1..i],
+  txInfoFee=mempty,
+  txInfoMint=mempty,
+  txInfoDCert=mempty,
+  txInfoWdrl=mempty,
+  txInfoValidRange=always,
+  txInfoSignatories=mempty,
+  txInfoData=mempty,
+  txInfoId=TxId ""
+  }
+
+mkTxOut :: Int -> TxOut
+mkTxOut i = TxOut {
+  txOutAddress=pubKeyHashAddress (PubKeyHash ""),
+  txOutValue=mkValue i,
+  txOutDatumHash=Nothing
+  }
+
+mkValue :: Int -> Value
+mkValue i = assetClassValue (assetClass adaSymbol adaToken) (fromIntegral i)
+
+-- This example decodes the script context (which is O(size-of-context) work), and then also
+-- does some work that's roughly proportional to the size of the script context (counting the
+-- outputs). This should be a somewhat realistic example where a reasonable chunk of work is
+-- done in addition to decoding.
+{-# INLINABLE checkScriptContext1 #-}
+checkScriptContext1 :: PlutusTx.BuiltinData -> ()
+checkScriptContext1 d =
+  -- Bang pattern to ensure this is forced, probably not necesssary
+  -- since we do use it later
+  let !sc = PlutusTx.unsafeFromBuiltinData d
+      (ScriptContext txi _) = sc
+  in
+  if PlutusTx.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0
+  then ()
+  else PlutusTx.traceError "Odd number of outputs"
+
+mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode ()
+mkCheckScriptContext1Code sc =
+  let d = PlutusTx.toBuiltinData sc
+  in $$(PlutusTx.compile [|| checkScriptContext1 ||]) `PlutusTx.applyCode` PlutusTx.liftCode d
+
+-- This example aims to *force* the decoding of the script context and then ignore it entirely.
+-- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces
+-- all the decoding work to be done even if it isn't used.
+{-# INLINABLE checkScriptContext2 #-}
+checkScriptContext2 :: PlutusTx.BuiltinData -> ()
+checkScriptContext2 d =
+  let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d
+  -- Just using a bang pattern was not enough to stop GHC from getting
+  -- rid of the dead binding before we even hit the plugin, this works
+  -- for now!
+  in case sc of
+    !_ ->
+      if 48*9900 PlutusTx.== (475200 :: Integer)
+      then ()
+      else PlutusTx.traceError "Got my sums wrong"
+
+mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode ()
+mkCheckScriptContext2Code sc =
+  let d = PlutusTx.toBuiltinData sc
+  in $$(PlutusTx.compile [|| checkScriptContext2 ||]) `PlutusTx.applyCode` PlutusTx.liftCode d

plutus-benchmark/script-contexts/test/Spec.hs

@@ -0,0 +1,51 @@
+module Main (main) where
+
+import Test.Tasty
+import Test.Tasty.Extras (TestNested, runTestNestedIn)
+import Test.Tasty.HUnit
+
+import PlutusBenchmark.Common (compiledCodeToTerm, runTermCek)
+
+import PlutusBenchmark.ScriptContexts
+
+import PlutusCore.Evaluation.Result
+import PlutusTx.Test qualified as Tx
+
+runTestNested :: TestNested -> TestTree
+runTestNested = runTestNestedIn ["script-contexts", "test"]
+
+testCheckSc1 :: TestTree
+testCheckSc1 = testGroup "checkScriptContext1"
+    [ testCase "succeed on 4" $ assertBool "evaluation failed" $ isEvaluationSuccess $
+        runTermCek $ compiledCodeToTerm $ mkCheckScriptContext1Code (mkScriptContext 4)
+    , testCase "fails on 5" $ assertBool "evaluation succeeded" $ isEvaluationFailure $
+        runTermCek $ compiledCodeToTerm $ mkCheckScriptContext1Code (mkScriptContext 5)
+    , Tx.fitsInto "checkScriptContext1 (size)" (mkCheckScriptContext1Code (mkScriptContext 1)) 2500
+    , runTestNested $ Tx.goldenBudget "checkScriptContext1-4" $
+        mkCheckScriptContext1Code (mkScriptContext 4)
+    , runTestNested $ Tx.goldenBudget "checkScriptContext1-20" $
+        mkCheckScriptContext1Code (mkScriptContext 20)
+    ]
+
+testCheckSc2 :: TestTree
+testCheckSc2 = testGroup "checkScriptContext2"
+    [ testCase "succeed on 4" $ assertBool "evaluation failed" $ isEvaluationSuccess $
+          runTermCek $ compiledCodeToTerm $ mkCheckScriptContext2Code (mkScriptContext 4)
+    , testCase "succeed on 5" $ assertBool "evaluation failed" $ isEvaluationSuccess $
+          runTermCek $ compiledCodeToTerm $ mkCheckScriptContext2Code (mkScriptContext 5)
+    , Tx.fitsInto "checkScriptContext2 (size)" (mkCheckScriptContext2Code (mkScriptContext 1)) 2400
+    , runTestNested $ Tx.goldenBudget "checkScriptContext2-4" $
+          mkCheckScriptContext2Code (mkScriptContext 4)
+    , runTestNested $ Tx.goldenBudget "checkScriptContext2-20" $
+          mkCheckScriptContext2Code (mkScriptContext 20)
+    ]
+
+allTests :: TestTree
+allTests =
+  testGroup "plutus-benchmark script-contexts tests"
+    [ testCheckSc1
+    , testCheckSc2
+    ]
+
+main :: IO ()
+main = defaultMain allTests

plutus-benchmark/script-contexts/test/checkScriptContext1-20.budget.golden

@@ -0,0 +1,3 @@
+({ cpu: 492446997
+| mem: 1613269
+})

plutus-benchmark/script-contexts/test/checkScriptContext1-4.budget.golden

@@ -0,0 +1,3 @@
+({ cpu: 141826245
+| mem: 466293
+})

plutus-benchmark/script-contexts/test/checkScriptContext2-20.budget.golden

@@ -0,0 +1,3 @@
+({ cpu: 438942997
+| mem: 1400528
+})

plutus-benchmark/script-contexts/test/checkScriptContext2-4.budget.golden

@@ -0,0 +1,3 @@
+({ cpu: 127689877
+| mem: 410384
+})