Merge pull request #2554 from input-output-hk/zachc/script-tracing

add traces to time plutus script evalutaiton
IntersectMBO · Nov 29, 2021 · 08154a4 · 08154a4
2 parents ecdb4d1 + bdcff02
commit 08154a4
Show file tree

Hide file tree

Showing 2 changed files with 56 additions and 2 deletions.
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PlutusScriptApi.hs
@@ -68,13 +68,15 @@ import Cardano.Slotting.Time (SystemStart)
 import Data.Coders
 import Data.Foldable (foldl')
 import Data.Functor.Identity (Identity, runIdentity)
+import Data.List (intercalate)
 import qualified Data.Map as Map
 import Data.Maybe (mapMaybe)
 import Data.Proxy (Proxy (..))
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Text (pack)
+import Debug.Trace (traceEvent)
 import GHC.Generics
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
@@ -242,8 +244,21 @@ evalScripts tx ((AlonzoScript.TimelockScript timelock, _, _, _) : rest) =
     lift True = Passes
     lift False = Fails [OnePhaseFailure . pack . show $ timelock]
 evalScripts tx ((AlonzoScript.PlutusScript lang pscript, ds, units, cost) : rest) =
-  runPLCScript (Proxy @era) lang cost pscript units (map getPlutusData ds)
-    `andResult` evalScripts tx rest
+  let beginMsg =
+        intercalate
+          ","
+          [ "[LEDGER][PLUTUS_SCRIPT]",
+            "BEGIN"
+          ]
+      !res = traceEvent beginMsg $ runPLCScript (Proxy @era) lang cost pscript units (map getPlutusData ds)
+      endMsg =
+        intercalate
+          ","
+          [ "[LEDGER][PLUTUS_SCRIPT]",
+            "END",
+            "res = " <> show res
+          ]
+   in (traceEvent endMsg res) `andResult` evalScripts tx rest
 
 -- Collect information (purpose and hash) about all the scripts in a Tx.
 -- THE SPEC CALLS FOR A SET, BUT THAT NEEDS A BUNCH OF ORD INSTANCES (DCert)

diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -67,9 +68,11 @@ import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended
 import Data.Coders
 import Data.Foldable (toList)
+import Data.List (intercalate)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
+import Debug.Trace (traceEvent)
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (NoThunks)
@@ -182,6 +185,15 @@ scriptsValidateTransition = do
         totalDeposits pp (`Map.notMember` poolParams) txcerts <-> refunded
   sysSt <- liftSTS $ asks systemStart
   ei <- liftSTS $ asks epochInfo
+  let !_ =
+        traceEvent
+          ( intercalate
+              ","
+              [ "[LEDGER][SCRIPTS_VALIDATION]",
+                "BEGIN"
+              ]
+          )
+          ()
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
       case evalScripts @era tx sLst of
@@ -192,6 +204,15 @@ scriptsValidateTransition = do
               (FailedUnexpectedly sss)
         Passes -> pure ()
     Left info -> failBecause (CollectErrors info)
+  let !_ =
+        traceEvent
+          ( intercalate
+              ","
+              [ "[LEDGER][SCRIPTS_VALIDATION]",
+                "END"
+              ]
+          )
+          ()
   pup' <-
     trans @(Core.EraRule "PPUP" era) $
       TRC
@@ -232,12 +253,30 @@ scriptsNotValidateTransition = do
   let txb = body tx
   sysSt <- liftSTS $ asks systemStart
   ei <- liftSTS $ asks epochInfo
+  let !_ =
+        traceEvent
+          ( intercalate
+              ","
+              [ "[LEDGER][SCRIPTS_NOT_VALIDATE_TRANSITION]",
+                "BEGIN"
+              ]
+          )
+          ()
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
       case evalScripts @era tx sLst of
         Passes -> False ?!## ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
         Fails _sss -> pure ()
     Left info -> failBecause (CollectErrors info)
+  let !_ =
+        traceEvent
+          ( intercalate
+              ","
+              [ "[LEDGER][SCRIPTS_NOT_VALIDATE_TRANSITION]",
+                "END"
+              ]
+          )
+          ()
   pure $
     us
       { _utxo = eval (getField @"collateral" txb ⋪ utxo),