Call trace for failing evaluation via new emitter mode (#7178)

* Call trace for failing evaluation via new emitter mode

* Update goldens for `Plugin.Profiling`

* Change enter/exit marker with arrows

* Update srcspan formatting, formatting

* Review changes

* Add note about profiling marker

* Use NoImplicitPrelude

* Add link to issue for source span problem

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/executables/traceToStacks/Common.hs

@@ -64,9 +64,10 @@ parseProfileEvent valIx (LogRow str vals) =
   let val = vals !! (valIx-1)
   in case words str of
     [transition,var] ->
+      -- See Note [Profiling Marker]
       case transition of
-        "entering" -> MkProfileEvent val Enter (T.pack var)
-        "exiting" -> MkProfileEvent val Exit (T.pack var)
+        "->" -> MkProfileEvent val Enter (T.pack var)
+        "<-" -> MkProfileEvent val Exit (T.pack var)
         badLog -> error $
           "parseProfileEvent: expecting \"entering\" or \"exiting\" but got "
           <> show badLog
@@ -105,4 +106,3 @@ getStacks = go []
     go [] [] = []
     go stacks [] = error $
       "getStacks; go: stack " <> show stacks <> " isn't empty but the log is."
-

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,11 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode
-  ( noEmitter
-  , logEmitter
-  , logWithTimeEmitter
-  , logWithBudgetEmitter
-  ) where
+module UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode (
+  noEmitter,
+  logEmitter,
+  logWithTimeEmitter,
+  logWithBudgetEmitter,
+  logWithCallTraceEmitter,
+) where
 
 import UntypedPlutusCore.Evaluation.Machine.Cek.Internal
 
@@ -68,3 +70,36 @@ 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 "-> rob:Example.hs:3:1-3:15" and "<-
+bob:Example.hs:1:1-1:13" with "->" and "<-" 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 =
+        -- See Note [Profiling Marker]
+        case (T.words (last l), T.words x) of
+          ("->" : enterRest, "<-" : 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.Lib
+    CallTrace.OtherModule
+    CallTrace.Spec
     DataList.Budget.Spec
     Inline.Spec
     IntegerLiterals.NoStrict.NegativeLiterals.Spec
@@ -196,6 +199,7 @@ test-suite plutus-tx-plugin-tests
     , plutus-tx                        ^>=1.49
     , plutus-tx-plugin                 ^>=1.49
     , 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,32 @@ 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
+        -- When module is not compiled and GHC is using cached build from previous build, it will
+        -- lack source span. There's nothing much we can do about this here since this is GHC
+        -- behavior. Issue #7203
+        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
@@ -765,6 +777,18 @@ entryExitTracingInside lamName displayName = go mempty
     let ty' = PLC.typeSubstTyNames (\tn -> Map.lookup tn subst) ty
      in entryExitTracing lamName displayName e ty'
 
+{- Note [Profiling Markers]
+   The @profile-all@ will insert trarces when entering and exciting functions. These
+   traces have a string marker to indicate that a given traces message is for enter/exit
+   marking. Markers are just simple strings: "->" and "<-". So for any reason in the
+   future this marker needs to be changed, all of utilities that uses this marker will
+   need to be updated.
+
+   This list will track of all of the utilities that uses this marker:
+   - plutus-core:traceToStacks
+   - @UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode.logWithCallTraceEmitter@
+-}
+
 -- | Add tracing before entering and after exiting a term.
 entryExitTracing
   :: PLC.Name
@@ -780,9 +804,10 @@ entryExitTracing lamName displayName e ty =
         annMayInline
         ( mkTrace
             (PLC.TyFun annMayInline defaultUnitTy ty) -- ()-> ty
-            ("entering " <> displayName)
+            -- See Note [Profiling Marker]
+            ("-> " <> displayName)
             -- \() -> trace @c "exiting f" e
-            (LamAbs annMayInline lamName defaultUnitTy (mkTrace ty ("exiting " <> displayName) e))
+            (LamAbs annMayInline lamName defaultUnitTy (mkTrace ty ("<- " <> displayName) e))
         )
         defaultUnit
 
@@ -1159,16 +1184,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