Call trace for failing evaluation via new emitter mode

Author: SeungheonOh

plutus-core/changelog.d/20250702_004055_seungheon.ooh_7146_2.md

@@ -0,0 +1,4 @@
+### Added
+
+- Added a new emitter mode `logWithCallTraceEmitter` which uses trace messages generated by `PlutusTx.Plugin:profile-all` flag of plutus-tx-plugin to create call trace of the functions that led to the evaluation failure. If script passes or script is not compiled with `profile-all` flag, `logWithCallTraceEmitter` will behave as regular `logEmitter`.
+

plutus-core/executables/src/PlutusCore/Executable/Types.hs

@@ -55,7 +55,13 @@ data TimingMode = NoTiming | Timing Integer deriving stock (Eq) -- Report progra
 data CekModel = Default | Unit -- Which cost model should we use for CEK machine steps?
 data PrintMode = Classic | Simple | Readable | ReadableSimple deriving stock (Show, Read)
 data NameFormat = IdNames | DeBruijnNames -- Format for textual output of names
-data TraceMode = None | Logs | LogsWithTimestamps | LogsWithBudgets deriving stock (Show, Read)
+data TraceMode
+  = None
+  | Logs
+  | LogsWithTimestamps
+  | LogsWithBudgets
+  | LogsWithCallTrace
+  deriving stock (Show, Read)
 type ExampleName = T.Text
 data ExampleMode = ExampleSingle ExampleName | ExampleAvailable
 
@@ -95,4 +101,3 @@ pirFormatToFormat FlatNamed  = Flat Named
 
 -- | Output types for some pir commands
 data Language = PLC | UPLC
-

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs

@@ -40,6 +40,7 @@ module UntypedPlutusCore.Evaluation.Machine.Cek
     , logEmitter
     , logWithTimeEmitter
     , logWithBudgetEmitter
+    , logWithCallTraceEmitter
     -- * Misc
     , BuiltinsRuntime (..)
     , CekValue (..)

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs

@@ -1,10 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode
   ( noEmitter
   , logEmitter
   , logWithTimeEmitter
   , logWithBudgetEmitter
+  , logWithCallTraceEmitter
   ) where
 
 import UntypedPlutusCore.Evaluation.Machine.Cek.Internal
@@ -68,3 +70,35 @@ logWithBudgetEmitter = EmitterMode $ \getBudget -> do
         let withBudget = logs <&> \str -> encodeRecord (str, exCpu, exMemory)
         modifySTRef logsRef (`DList.append` withBudget)
   pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef)
+
+{- | Emits log and, when script evaluation fails, call trace.
+
+This requires script to be compiled with `PlutusTx.Plugin:profile-all` turned on because this relies
+on compiler-generated trace calls that notifies entrance and exit of a function call. These traces
+that mark entrance and exit are ordinary traces like "entering rob:Example.hs:3:1-3:15" and "exiting
+bob:Example.hs:1:1-1:13" with "entering" and "exiting" prefixies, where "bob" and "rob" is the name
+of the function with source span. If regular script with no entrance/exit marker is given, this
+emitter will behave identically to 'logEmitter'.
+
+When script evaluation fails, this emitter will give call trace of the functions that led to the
+evaluation failure.  This is useful for pin-pointing specific area of the codebase that caused
+failure when debugging a script. When script evaluation passes, every trace message generated by
+`profile-all` flag will be removed, and this emitter will behave identically to 'logEmitter'.
+-}
+logWithCallTraceEmitter :: EmitterMode uni fun
+logWithCallTraceEmitter = EmitterMode $ \_ -> do
+  logsRef <- newSTRef DList.empty
+  let
+    addTrace DList.Nil logs = logs
+    addTrace newLogs DList.Nil = newLogs
+    addTrace newLogs logs = DList.fromList $ go (DList.toList newLogs) (DList.toList logs)
+      where
+        go l [] = l
+        go [] l = l
+        go (x:xs) l =
+          case (T.words (last l), T.words x) of
+            ("entering":enterRest, "exiting":exitRest) | enterRest == exitRest -> go xs (init l)
+            _                                                                  -> go xs (l <> [x])
+
+    emitter logs = CekM $ modifySTRef logsRef (addTrace logs)
+  pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef)

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs

@@ -42,6 +42,7 @@ module UntypedPlutusCore.Evaluation.Machine.CommonAPI
     , logEmitter
     , logWithTimeEmitter
     , logWithBudgetEmitter
+    , logWithCallTraceEmitter
     -- * Misc
     , CekValue(..)
     , readKnownCek

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs

@@ -38,6 +38,7 @@ module UntypedPlutusCore.Evaluation.Machine.SteppableCek
     , logEmitter
     , logWithTimeEmitter
     , logWithBudgetEmitter
+    , logWithCallTraceEmitter
     -- * Misc
     , CekValue(..)
     , readKnownCek

plutus-executables/executables/uplc/Main.hs

@@ -384,6 +384,7 @@ runEval (EvalOptions inp ifmt printMode nameFormat budgetMode traceMode
             Logs               -> Cek.logEmitter
             LogsWithTimestamps -> Cek.logWithTimeEmitter
             LogsWithBudgets    -> Cek.logWithBudgetEmitter
+            LogsWithCallTrace  -> Cek.logWithCallTraceEmitter
     -- Need the existential cost type in scope
     let budgetM = case budgetMode of
             Silent     -> SomeBudgetMode Cek.restrictingEnormous

plutus-tx-plugin/plutus-tx-plugin.cabal

@@ -136,6 +136,9 @@ test-suite plutus-tx-plugin-tests
     BuiltinList.Budget.Spec
     ByteStringLiterals.Lib
     ByteStringLiterals.Spec
+    CallTrace.OtherModule
+    CallTrace.Spec
+    CallTrace.Utils
     DataList.Budget.Spec
     Inline.Spec
     IntegerLiterals.NoStrict.NegativeLiterals.Spec
@@ -186,6 +189,7 @@ test-suite plutus-tx-plugin-tests
     , bytestring
     , containers
     , deepseq
+    , dlist
     , filepath
     , flat                             ^>=0.6
     , hedgehog
@@ -196,6 +200,7 @@ test-suite plutus-tx-plugin-tests
     , plutus-tx                        ^>=1.48
     , plutus-tx-plugin                 ^>=1.48
     , plutus-tx:plutus-tx-testlib
+    , prettyprinter
     , serialise
     , tasty
     , tasty-golden

plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs

@@ -64,7 +64,6 @@ import PlutusIR.Purity qualified as PIR
 import PlutusCore qualified as PLC
 import PlutusCore.Data qualified as PLC
 import PlutusCore.MkPlc qualified as PLC
-import PlutusCore.Pretty qualified as PP
 import PlutusCore.StdLib.Data.Function qualified
 import PlutusCore.Subst qualified as PLC
 
@@ -650,19 +649,31 @@ hoistExpr var t = do
         (PIR.Def var' (PIR.mkVar var', PIR.Strict))
         mempty
 
-      t' <- maybeProfileRhs var' =<< addSpan (compileExpr t)
+      t' <- maybeProfileRhs var var' =<< addSpan (compileExpr t)
       -- See Note [Non-strict let-bindings]
       PIR.modifyTermDef lexName (const $ PIR.Def var' (t', PIR.NonStrict))
       pure $ PIR.mkVar var'
 
+-- 'GHC.Var' in argument is only for extracting srcspan and accurate name.
 maybeProfileRhs
-  :: (CompilingDefault uni fun m ann) => PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
-maybeProfileRhs var t = do
+  :: (CompilingDefault uni fun m ann)
+  => GHC.Var
+  -> PLCVar uni
+  -> PIRTerm uni fun
+  -> m (PIRTerm uni fun)
+maybeProfileRhs ghcVar var t = do
   CompileContext{ccOpts = compileOpts} <- ask
-  let ty = PLC._varDeclType var
-      varName = PLC._varDeclName var
-      displayName = T.pack $ PP.displayPlcSimple varName
-      isFunctionOrAbstraction = case ty of PLC.TyFun{} -> True; PLC.TyForall{} -> True; _ -> False
+  let
+    nameStr = GHC.occNameString $ GHC.occName $ GHC.varName $ ghcVar
+    displayName = T.pack $
+      case getVarSourceSpan ghcVar of
+        -- FIXME: Variables will miss span information when the module they are defined
+        -- in is loaded from cache instead of getting compiled.
+        Nothing  -> nameStr
+        Just src -> nameStr <> ":" <> show (src ^. srcSpanIso)
+
+    ty = PLC._varDeclType var
+    isFunctionOrAbstraction = case ty of PLC.TyFun{} -> True; PLC.TyForall{} -> True; _ -> False
   -- Trace only if profiling is on *and* the thing being defined is a function
   if coProfile compileOpts == All && isFunctionOrAbstraction
     then do
@@ -1159,16 +1170,16 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do
         _ -> compileTypeNorm $ GHC.varType b
       -- See Note [Non-strict let-bindings]
       withVarTyScoped b ty $ \v -> do
-        rhs'' <- maybeProfileRhs v rhs'
+        rhs'' <- maybeProfileRhs b v rhs'
         let binds = pure $ PIR.TermBind annMayInline PIR.NonStrict v rhs''
         body' <- compileExpr body
         pure $ PIR.Let annMayInline PIR.NonRec binds body'
     GHC.Let (GHC.Rec bs) body ->
       withVarsScoped (fmap (second (const Nothing)) bs) $ \vars -> do
         -- the bindings are scope in both the body and the args
         -- TODO: this is a bit inelegant matching the vars back up
-        binds <- for (zip vars bs) $ \(v, (_, rhs)) -> do
-          rhs' <- maybeProfileRhs v =<< compileExpr rhs
+        binds <- for (zip vars bs) $ \(v, (ghcVar, rhs)) -> do
+          rhs' <- maybeProfileRhs ghcVar v =<< compileExpr rhs
           -- See Note [Non-strict let-bindings]
           pure $ PIR.TermBind annMayInline PIR.NonStrict v rhs'
         body' <- compileExpr body

plutus-tx-plugin/test/CallTrace/9.6/func01.eval.golden

@@ -0,0 +1,12 @@
+An error has occurred:
+The machine terminated because of an error, either from a built-in function or from an explicit use of 'error'.
+Caused by: error
+
+Trace:
+entering func:test/CallTrace/Spec.hs:69:1-69:4
+func 1
+entering nestedLinear:test/CallTrace/Spec.hs:62:1-62:12
+entering nestedLinear2:test/CallTrace/Spec.hs:63:1-63:13
+entering nestedLinear3:test/CallTrace/Spec.hs:64:1-64:13
+entering nestedLinear4:test/CallTrace/Spec.hs:65:1-65:13
+entering error