Merge #4907

4907: workbench | tx-generator: SECP benchmarking r=deepfire a=mgmeier

This PR expands the benchmarking machinery to enable SECP benchmarking.

- add `plutuscall-*` profile family to workbench
- add `model-*` profile family to workbench
- additional loop calibration strategies for tx-generator, where previously only 'maximize per-tx-budget expenditure' was possible
- make tx-generator emit a Plutus budget summary after loop calibration (via `TraceBenchPlutusBudgetSummary`)
- plus several small convenience improvements

Co-authored-by: Michael Karg <[email protected]>

Author: iohk-bors[bot]

Makefile

@@ -77,6 +77,11 @@ PROFILES_BASE         := default plutus plutus-secp-ecdsa plutus-secp-schnorr ol
 PROFILES_STARTSTOP    := startstop startstop-p2p startstop-plutus startstop-notracer startstop-oldtracing
 PROFILES_CI_TEST      := ci-test ci-test-p2p ci-test-plutus ci-test-notracer ci-test-dense10 aws-test
 PROFILES_CI_BENCH     := ci-bench ci-bench-p2p ci-bench-plutus ci-bench-plutus-secp-ecdsa ci-bench-plutus-secp-schnorr ci-bench-notracer
+PROFILES_PLUTUSCALL   := plutuscall-loop-plain plutuscall-secp-ecdsa-plain plutuscall-secp-schnorr-plain
+PROFILES_PLUTUSCALL   += plutuscall-loop-half plutuscall-secp-ecdsa-half plutuscall-secp-schnorr-half
+PROFILES_PLUTUSCALL   += plutuscall-loop-double plutuscall-secp-ecdsa-double plutuscall-secp-schnorr-double
+PROFILES_MODEL		  := model-value model-secp-ecdsa-plain model-secp-ecdsa-half model-secp-ecdsa-double
+PROFILES_MODEL		  += model-value-test
 PROFILES_10           := 10 10-p2p 10-plutus 10-notracer
 PROFILES_FORGE_STRESS := forge-stress forge-stress-p2p forge-stress-plutus forge-stress-plutus-singleton forge-stress-notracer
 PROFILES_FORGE_STRESS_PRE := forge-stress-pre forge-stress-pre-plutus forge-stress-pre-notracer
@@ -88,6 +93,8 @@ SHELL_PROFILES += $(PROFILES_BASE)
 SHELL_PROFILES += $(PROFILES_STARTSTOP)
 SHELL_PROFILES += $(PROFILES_CI_TEST)
 SHELL_PROFILES += $(PROFILES_CI_BENCH)
+SHELL_PROFILES += $(PROFILES_PLUTUSCALL)
+SHELL_PROFILES += $(PROFILES_MODEL)
 SHELL_PROFILES += $(PROFILES_10)
 SHELL_PROFILES += $(PROFILES_FORGE_STRESS)
 SHELL_PROFILES += $(PROFILES_FORGE_STRESS_PRE)

bench/plutus-scripts-bench/plutus-scripts-bench.cabal

@@ -47,6 +47,7 @@ common common-definitions
 
 library
   import:          common-definitions
+                 , project-config
   hs-source-dirs:  src
 
   if flag(unexpected_thunks)

bench/tx-generator/src/Cardano/Benchmarking/Command.hs

@@ -47,6 +47,11 @@ runCommand = withIOManager $ \iocp -> do
     JsonHL file nodeConfigOverwrite cardanoTracerOverwrite -> do
       opts <- parseJSONFile fromJSON file
       finalOpts <- mangleTracerConfig cardanoTracerOverwrite <$> mangleNodeConfig nodeConfigOverwrite opts
+
+      Prelude.putStrLn $ 
+          "--> initial options:\n" ++ show opts ++
+        "\n--> final options:\n" ++ show finalOpts
+
       case compileOptions finalOpts of
         Right script -> runScript script iocp >>= handleError
         err -> handleError err

bench/tx-generator/src/Cardano/Benchmarking/Compiler.hs

@@ -137,7 +137,7 @@ splittingPhase srcWallet = do
   plutusPayMode :: DstWallet -> Compiler PayMode
   plutusPayMode dst = do
     ~(Just plutus@PlutusOn{..}) <- askNixOption _nix_plutus
-    scriptSpec <- if plutusType == LimitSaturationLoop
+    scriptSpec_ <- if hasLoopCalibration plutusType
       then case plutusRedeemer of
         Nothing -> throwCompileError $ SomeCompilerError "Plutus loop autoscript requires a redeemer."
         Just redeemer -> do
@@ -154,7 +154,7 @@ splittingPhase srcWallet = do
                       executionUnits
                       debugMode
           pure $ ScriptSpec plutusScript budget
-    return $ PayToScript scriptSpec dst
+    return $ PayToScript (scriptSpec_ plutusType) dst
 
 -- Generate src and dst wallet names for a splitSequence.
 -- testCompiler (error "opts") $ splitSequenceWalletNames (WalletName "w1") (WalletName "w2") (unfoldSplitSequence 1 1000 10000)

bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs

@@ -48,7 +48,7 @@ type AsyncBenchmarkControl = (Async (), [Async ()], IO SubmissionSummary, IO ())
 waitBenchmark :: Tracer IO (TraceBenchTxSubmit TxId) -> AsyncBenchmarkControl -> ExceptT TxGenError IO ()
 waitBenchmark traceSubmit (feeder, workers, mkSummary, _) = liftIO $ do
   mapM_ waitCatch (feeder : workers)
-  traceWith traceSubmit =<< TraceBenchTxSubSummary <$> mkSummary
+  traceWith traceSubmit . TraceBenchTxSubSummary =<< mkSummary
 
 lookupNodeAddress ::
   NodeAddress' NodeHostIPv4Address -> IO AddrInfo

bench/tx-generator/src/Cardano/Benchmarking/LogTypes.hs

@@ -52,6 +52,7 @@ import           Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2)
 
 import           Cardano.Benchmarking.Types
 import           Cardano.Benchmarking.Version as Version
+import           Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary)
 import           Cardano.TxGenerator.Types (TPSRate)
 
 data BenchTracers =
@@ -96,6 +97,8 @@ data TraceBenchTxSubmit txid
   -- ^ SubmissionSummary.
   | TraceBenchTxSubDebug String
   | TraceBenchTxSubError Text
+  | TraceBenchPlutusBudgetSummary PlutusBudgetSummary
+  -- ^ PlutusBudgetSummary.
   deriving stock (Show, Generic)
 
 data SubmissionSummary

bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs

@@ -281,6 +281,7 @@ evalGenerator :: forall era. IsShelleyBasedEra era => Generator -> TxGenTxParams
 evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
   networkId <- getEnvNetworkId
   protocolParameters <- getProtocolParameters
+
   case generator of
     SecureGenesis wallet genesisKeyName destKeyName -> do
       genesis  <- getEnvGenesis
@@ -294,6 +295,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
           walletRefInsertFund destWallet fund
           return $ Right tx
       return $ Streaming.effect (Streaming.yield <$> gen)
+
     Split walletName payMode payModeChange coins -> do
       wallet <- getEnvWallets walletName
       (toUTxO, addressOut) <- interpretPayMode payMode
@@ -306,6 +308,7 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
         txGenerator = genTx protocolParameters (TxInsCollateralNone, []) feeInEra TxMetadataNone
         sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut $ mangleWithChange toUTxOChange toUTxO
       return $ Streaming.effect (Streaming.yield <$> sourceToStore)
+
     SplitN walletName payMode count -> do
       wallet <- getEnvWallets walletName
       (toUTxO, addressOut) <- interpretPayMode payMode
@@ -327,16 +330,36 @@ evalGenerator generator txParams@TxGenTxParams{txParamFee = fee} era = do
         inToOut = Utils.inputsToOutputsWithFee fee outputs
         txGenerator = genTx protocolParameters collaterals feeInEra (toMetadata metadataSize)
         sourceToStore = sourceToStoreTransactionNew txGenerator fundSource inToOut (mangle $ repeat toUTxO)
+
+      fundPreview <- liftIO $ walletPreview wallet inputs
+      case sourceTransactionPreview txGenerator fundPreview inToOut (mangle $ repeat toUTxO) of
+        Left err -> traceDebug $ "Error creating Tx preview: " ++ show err
+        Right tx -> do
+          let txSize = txSizeInBytes tx
+          traceDebug $ "Projected Tx size in bytes: " ++ show txSize
+          summary_ <- getEnvSummary
+          forM_ summary_ $ \summary -> do
+            let summary' = summary {projectedTxSize = Just txSize}
+            setEnvSummary summary'
+            traceBenchTxSubmit TraceBenchPlutusBudgetSummary summary'
+          dumpBudgetSummaryIfExisting
+
       return $ Streaming.effect (Streaming.yield <$> sourceToStore)
+
     Sequence l -> do
       gList <- forM l $ \g -> evalGenerator g txParams era
       return $ Streaming.for (Streaming.each gList) id
+
     Cycle g -> Streaming.cycle <$> evalGenerator g txParams era
+
     Take count g -> Streaming.take count <$> evalGenerator g txParams era
+
     RoundRobin l -> do
       _gList <- forM l $ \g -> evalGenerator g txParams era
       error "return $ foldr1 Streaming.interleaves gList"
+
     OneOf _l -> error "todo: implement Quickcheck style oneOf generator"
+
   where
     feeInEra = Utils.mkTxFee fee
 
@@ -414,29 +437,30 @@ makePlutusContext ScriptSpec{..} = do
             ]
       return (sData, redeemer, units)
 
-    AutoScript redeemerFile budgetFraction -> do
+    AutoScript redeemerFile txInputs -> do
       redeemer <- liftIOSafe $ readScriptData redeemerFile
       let
-        budget = ExecutionUnits
-                    (executionSteps perTxBudget  `div` fromIntegral budgetFraction)
-                    (executionMemory perTxBudget `div` fromIntegral budgetFraction)
+        strategy = case scriptSpecPlutusType of
+          LimitTxPerBlock_8 -> TargetTxsPerBlock 8
+          _                 -> TargetTxExpenditure
 
         -- reflects properties hard-coded into the loop scripts for benchmarking:
         -- 1. script datum is not used
         -- 2. the loop terminates at 1_000_000 when counting down
         -- 3. the loop's initial value is the first numerical value in the redeemer argument structure
         autoBudget = PlutusAutoBudget
-          { autoBudgetUnits = budget
+          { autoBudgetUnits = perTxBudget
           , autoBudgetDatum = ScriptDataNumber 0
           , autoBudgetRedeemer = scriptDataModifyNumber (const 1_000_000) redeemer
           }
-      traceDebug $ "Plutus auto mode : Available budget per Tx input / script run: " ++ show budget
-                   ++ " -- fraction of protocolParamMaxTxExUnits budget: 1/" ++ show budgetFraction
+      traceDebug $ "Plutus auto mode : Available budget per Tx: " ++ show perTxBudget
+                   ++ " -- split between inputs per Tx: " ++ show txInputs
 
-      case plutusAutoBudgetMaxOut protocolParameters script autoBudget of
+      case plutusAutoScaleBlockfit protocolParameters scriptSpecFile script autoBudget strategy txInputs of
         Left err -> liftTxGenError err
-        Right PlutusAutoBudget{..} -> do
-          preRun <- preExecuteScriptAction protocolParameters script autoBudgetDatum autoBudgetRedeemer
+        Right (summary, PlutusAutoBudget{..}, preRun) -> do
+          setEnvSummary summary
+          dumpBudgetSummaryIfExisting
           return (autoBudgetDatum, autoBudgetRedeemer, preRun)
 
   let msg = mconcat [ "Plutus Benchmark :"
@@ -485,6 +509,16 @@ preExecuteScriptAction protocolParameters script scriptData redeemer
       Left err -> throwE $ WalletError ( "makePlutusContext preExecuteScript failed: " ++ show err )
       Right costs -> return costs
 
+dumpBudgetSummaryIfExisting :: ActionM ()
+dumpBudgetSummaryIfExisting
+  = do
+    summary_ <- getEnvSummary
+    forM_ summary_ $ \summary -> do
+      liftIO $ BSL.writeFile summaryFile $ prettyPrintOrdered summary
+      traceDebug $ "dumpBudgetSummaryIfExisting : budget summary created/updated in: " ++ summaryFile
+  where
+    summaryFile = "plutus-budget-summary.json"
+
 traceTxGeneratorVersion :: ActionM ()
 traceTxGeneratorVersion = traceBenchTxSubmit TraceTxGeneratorVersion Version.txGeneratorVersion
 

bench/tx-generator/src/Cardano/Benchmarking/Script/Env.hs

@@ -39,6 +39,8 @@ module Cardano.Benchmarking.Script.Env (
         , setEnvThreads
         , getEnvWallets
         , setEnvWallets
+        , getEnvSummary
+        , setEnvSummary
 ) where
 
 import           Control.Monad.IO.Class
@@ -61,8 +63,10 @@ import           Cardano.Benchmarking.Wallet
 import           Cardano.Node.Protocol.Types (SomeConsensusProtocol)
 import           Ouroboros.Network.NodeToClient (IOManager)
 
+import           Cardano.TxGenerator.PlutusContext (PlutusBudgetSummary)
 import           Cardano.TxGenerator.Types (TxGenError (..))
 
+
 data Env = Env { protoParams :: Maybe ProtocolParameterMode
                , benchTracers :: Maybe Tracer.BenchTracers
                , envGenesis :: Maybe (ShelleyGenesis StandardShelley)
@@ -72,6 +76,7 @@ data Env = Env { protoParams :: Maybe ProtocolParameterMode
                , envKeys :: Map String (SigningKey PaymentKey)
                , envThreads :: Map String AsyncBenchmarkControl
                , envWallets :: Map String WalletRef
+               , envSummary :: Maybe PlutusBudgetSummary
                }
 
 emptyEnv :: Env
@@ -84,6 +89,7 @@ emptyEnv = Env { protoParams = Nothing
                , envSocketPath = Nothing
                , envThreads = Map.empty
                , envWallets = Map.empty
+               , envSummary = Nothing
                }
 
 type ActionM a = ExceptT Error (RWST IOManager () Env IO) a
@@ -140,6 +146,9 @@ setEnvThreads key val = modifyEnv (\e -> e { envThreads = Map.insert key val (en
 setEnvWallets :: String -> WalletRef -> ActionM ()
 setEnvWallets key val = modifyEnv (\e -> e { envWallets = Map.insert key val (envWallets e) })
 
+setEnvSummary :: PlutusBudgetSummary -> ActionM ()
+setEnvSummary val = modifyEnv (\e -> e { envSummary = pure val })
+
 getEnvVal :: (Env -> Maybe t) -> String -> ActionM t
 getEnvVal acc s = do
   lift (RWS.gets acc) >>= \case
@@ -180,6 +189,9 @@ getEnvThreads = getEnvMap envThreads
 getEnvWallets :: String -> ActionM WalletRef
 getEnvWallets = getEnvMap envWallets
 
+getEnvSummary :: ActionM (Maybe PlutusBudgetSummary)
+getEnvSummary = lift (RWS.gets envSummary)
+
 traceBenchTxSubmit :: (forall txId. x -> Tracer.TraceBenchTxSubmit txId) -> x -> ActionM ()
 traceBenchTxSubmit tag msg = do
   tracers  <- getBenchTracers

bench/tx-generator/src/Cardano/Benchmarking/Script/Types.hs

@@ -17,7 +17,7 @@ module Cardano.Benchmarking.Script.Types (
         , ProtocolParameterMode(..)
         , ProtocolParametersSource(QueryLocalNode, UseLocalProtocolFile)
         , ScriptBudget(AutoScript, StaticScriptBudget)
-        , ScriptSpec(ScriptSpec, scriptSpecFile, scriptSpecBudget)
+        , ScriptSpec(..)
         , SubmitMode(Benchmark, DiscardTX, DumpToFile, LocalSocket,
                 NodeToNode)
         , TargetNodes
@@ -110,6 +110,7 @@ data ScriptSpec = ScriptSpec
   {
     scriptSpecFile :: !FilePath
   , scriptSpecBudget :: !ScriptBudget
+  , scriptSpecPlutusType :: !TxGenPlutusType
   }
   deriving (Show, Eq)
 deriving instance Generic ScriptSpec

bench/tx-generator/src/Cardano/Benchmarking/Tracer.hs

@@ -253,6 +253,10 @@ instance LogFormatting (TraceBenchTxSubmit TxId) where
       mconcat [ "kind" .= A.String "TraceBenchTxSubError"
               , "msg"  .= A.String s
               ]
+    TraceBenchPlutusBudgetSummary summary ->
+      mconcat [ "kind"    .= A.String "TraceBenchPlutusBudgetSummary"
+              , "summary" .= toJSON summary
+              ]
 
 instance MetaTrace (TraceBenchTxSubmit TxId) where
     namespaceFor TraceTxGeneratorVersion {} = Namespace [] ["TxGeneratorVersion"]
@@ -271,6 +275,7 @@ instance MetaTrace (TraceBenchTxSubmit TxId) where
     namespaceFor TraceBenchTxSubSummary {} = Namespace [] ["eBenchTxSubSummary"]
     namespaceFor TraceBenchTxSubDebug {} = Namespace [] ["BenchTxSubDebug"]
     namespaceFor TraceBenchTxSubError {} = Namespace [] ["BenchTxSubError"]
+    namespaceFor TraceBenchPlutusBudgetSummary {} = Namespace [] ["BenchPlutusBudgetSummary"]
 
     severityFor _ _ = Just Info
 
@@ -293,6 +298,7 @@ instance MetaTrace (TraceBenchTxSubmit TxId) where
         , Namespace [] ["eBenchTxSubSummary"]
         , Namespace [] ["BenchTxSubDebug"]
         , Namespace [] ["BenchTxSubError"]
+        , Namespace [] ["BenchPlutusBudgetSummary"]
         ]
 
 instance LogFormatting NodeToNodeSubmissionTrace where

bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs

@@ -56,7 +56,13 @@ mkWalletFundStore walletRef fund = modifyMVar_  walletRef
 walletSource :: WalletRef -> Int -> FundSource IO
 walletSource ref munch = modifyMVar ref $ \fifo -> return $ case removeFunds munch fifo of
   Nothing -> (fifo, Left $ TxGenError "WalletSource: out of funds")
-  Just (newFifo, funds) -> (newFifo, Right funds) 
+  Just (newFifo, funds) -> (newFifo, Right funds)
+
+-- just a preview of the wallet's funds; wallet remains unmodified
+walletPreview :: WalletRef -> Int -> IO [Fund]
+walletPreview ref munch = do
+  fifo <- readMVar ref
+  return $ maybe (toList fifo) snd (removeFunds munch fifo)
 
 mangleWithChange :: Monad m => CreateAndStore m era -> CreateAndStore m era -> CreateAndStoreList m era PayWithChange
 mangleWithChange mkChange mkPayment outs = case outs of