Add a compiler option to remove traces (#4219)

* Add a compiler option to remove traces

* Add remove-trace tests. Refactor plugin options in plutus-tx-plugin tests

* define builtin trace: use liftQuote instead of runQuote to maintain unique counting

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

@@ -97,6 +97,7 @@ test-suite plutus-tx-tests
         Plugin.Errors.Spec
         Plugin.Functions.Spec
         Plugin.Laziness.Spec
+        Plugin.NoTrace.Spec
         Plugin.Primitives.Spec
         Plugin.Profiling.Spec
         Plugin.Typeclasses.Spec
@@ -128,5 +129,4 @@ test-suite plutus-tx-tests
         ghc-prim -any,
         containers -any
     -- NOTE: -g makes the plugin give better errors
-    -- NOTE: we disable the simplifier as it simplifies away some tests
-    ghc-options: -g -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0
+    ghc-options: -g

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

@@ -42,6 +42,8 @@ import GhcPlugins qualified as GHC
 
 import Language.Haskell.TH.Syntax qualified as TH
 
+import Control.Monad.Reader (MonadReader (ask))
+
 import Data.ByteString qualified as BS
 import Data.Proxy
 import Data.Text (Text)
@@ -254,6 +256,7 @@ defineBuiltinType name ty = do
 -- | Add definitions for all the builtin terms to the environment.
 defineBuiltinTerms :: CompilingDefault uni fun m => m ()
 defineBuiltinTerms = do
+    CompileContext {ccOpts=compileOpts} <- ask
 
     -- See Note [Builtin terms and values]
     -- Bool
@@ -302,9 +305,24 @@ defineBuiltinTerms = do
     defineBuiltinTerm 'Builtins.appendString $ mkBuiltin PLC.AppendString
     defineBuiltinTerm 'Builtins.emptyString $ PIR.mkConstant () ("" :: Text)
     defineBuiltinTerm 'Builtins.equalsString $ mkBuiltin PLC.EqualsString
-    defineBuiltinTerm 'Builtins.trace $ mkBuiltin PLC.Trace
     defineBuiltinTerm 'Builtins.encodeUtf8 $ mkBuiltin PLC.EncodeUtf8
 
+    -- Tracing
+    -- When `remove-trace` is specified, we define `trace` as `\_ a -> a` instead of the builtin version.
+    traceTerm <- if coRemoveTrace compileOpts
+        then liftQuote $ do
+            ta <- freshTyName "a"
+            t <- freshName "t"
+            a <- freshName "a"
+            pure $ PIR.tyAbs () ta (PLC.Type ())
+                 $ PIR.mkIterLamAbs
+                    [ PIR.VarDecl () t (PIR.mkTyBuiltin @_ @Text ())
+                    , PIR.VarDecl () a (PLC.TyVar () ta)
+                    ]
+                 $ PIR.Var () a
+        else pure (mkBuiltin PLC.Trace)
+    defineBuiltinTerm 'Builtins.trace traceTerm
+
     -- Pairs
     defineBuiltinTerm 'Builtins.fst $ mkBuiltin PLC.FstPair
     defineBuiltinTerm 'Builtins.snd $ mkBuiltin PLC.SndPair

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

@@ -430,9 +430,9 @@ hoistExpr var t = do
                 (PIR.Def var' (PIR.mkVar () var', PIR.Strict))
                 mempty
 
-            CompileContext {ccOpts=profileOpts} <- ask
+            CompileContext {ccOpts=compileOpts} <- ask
             t' <-
-                if coProfile profileOpts==All then do
+                if coProfile compileOpts==All then do
                     let ty = PLC._varDeclType var'
                         varName = PLC._varDeclName var'
                     t'' <- compileExpr t

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

@@ -37,8 +37,9 @@ type NameInfo = Map.Map TH.Name GHC.TyThing
 
 -- | Compilation options.
 data CompileOptions = CompileOptions {
-      coProfile  :: ProfileOpts
-    , coCoverage :: CoverageOpts
+      coProfile     :: ProfileOpts
+    , coCoverage    :: CoverageOpts
+    , coRemoveTrace :: Bool
     }
 
 data CompileContext uni fun = CompileContext {

plutus-tx-plugin/src/PlutusTx/Plugin.hs

@@ -79,6 +79,12 @@ data PluginOptions = PluginOptions {
     , poDoSimplifierRemoveDeadBindings :: Bool
     , poProfile                        :: ProfileOpts
     , poCoverage                       :: CoverageOpts
+
+    -- Setting to `True` defines `trace` as `\_ a -> a` instead of the builtin version.
+    -- Which effectively ignores the trace text.
+    -- TODO: when simpilers are enabled, we should reduce and inline a `\_ a -> a` call to just `a`.
+    -- Reducing `test/Plugin/NoTrace/traceComplex.plc.golden` is a good start.
+    , poRemoveTrace                    :: Bool
     }
 
 data PluginCtx = PluginCtx
@@ -167,6 +173,7 @@ parsePluginArgs args = do
                    [ l | l <- [minBound .. maxBound], elem' "coverage-all" ]
                 ++ [ LocationCoverage  | elem' "coverage-location"  ]
                 ++ [ BooleanCoverage  | elem' "coverage-boolean"  ]
+            , poRemoveTrace = elem' "remove-trace"
             }
     -- TODO: better parsing with failures
     pure opts
@@ -337,7 +344,7 @@ compileMarkedExpr locStr codeTy origE = do
     nameInfo <- makePrimitiveNameInfo $ builtinNames ++ [''Bool, 'False, 'True, 'traceBool]
     modBreaks <- asks pcModuleModBreaks
     let ctx = CompileContext {
-            ccOpts = CompileOptions {coProfile =poProfile opts , coCoverage = poCoverage opts },
+            ccOpts = CompileOptions {coProfile=poProfile opts,coCoverage=poCoverage opts,coRemoveTrace=poRemoveTrace opts},
             ccFlags = flags,
             ccFamInstEnvs = famEnvs,
             ccNameInfo = nameInfo,

plutus-tx-plugin/test/Budget/Lib.hs

@@ -4,9 +4,7 @@
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
-{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
-{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
-{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
+
 module Budget.Lib where
 
 import Common

plutus-tx-plugin/test/Budget/Spec.hs

@@ -7,7 +7,9 @@
 {-# LANGUAGE TypeApplications      #-}
 {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
+
 module Budget.Spec where
 
 import Budget.Lib (goldenBudget)

plutus-tx-plugin/test/IsData/Spec.hs

@@ -8,7 +8,9 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
+
 module IsData.Spec where
 
 import Common

plutus-tx-plugin/test/Lib.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
@@ -10,15 +11,22 @@
 module Lib where
 
 import Common
+import Control.Exception
+import Control.Lens.Combinators (_1)
+import Control.Monad.Except
+import Data.Text (Text)
+import Flat (Flat)
+
 import PlcTestUtils
 
+import PlutusPrelude (view)
 import PlutusTx.Code
+import PlutusTx.Evaluation
 
 import PlutusCore qualified as PLC
-import PlutusCore.Pretty (PrettyConst)
+import PlutusCore.Pretty
 
-import Flat (Flat)
-import Prettyprinter
+import UntypedPlutusCore qualified as UPLC
 
 instance (PLC.Closed uni, uni `PLC.Everywhere` Flat, uni `PLC.Everywhere` PrettyConst, PLC.GShow uni, Pretty fun, Flat fun) =>
             ToUPlc (CompiledCodeIn uni fun a) uni fun where
@@ -30,3 +38,26 @@ goldenPir
     :: (PLC.Closed uni, uni `PLC.Everywhere` PrettyConst, uni `PLC.Everywhere` Flat, PLC.GShow uni, Pretty fun, Flat fun)
     => String -> CompiledCodeIn uni fun a -> TestNested
 goldenPir name value = nestedGoldenVsDoc name $ pretty $ getPir value
+
+runPlcCek :: ToUPlc a PLC.DefaultUni PLC.DefaultFun => [a] -> ExceptT SomeException IO (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ())
+runPlcCek values = do
+     ps <- traverse toUPlc values
+     let p = foldl1 UPLC.applyProgram ps
+     either (throwError . SomeException) pure $ evaluateCek p
+
+runPlcCekTrace ::
+     ToUPlc a PLC.DefaultUni PLC.DefaultFun =>
+     [a] ->
+     ExceptT SomeException IO ([Text], CekExTally PLC.DefaultFun, UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ())
+runPlcCekTrace values = do
+     ps <- traverse toUPlc values
+     let p = foldl1 UPLC.applyProgram ps
+     let (logOut, TallyingSt tally _, result) = evaluateCekTrace p
+     res <- either (throwError . SomeException) pure result
+     pure (logOut, tally, res)
+
+goldenEvalCek :: ToUPlc a PLC.DefaultUni PLC.DefaultFun => String -> [a] -> TestNested
+goldenEvalCek name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug <$> (rethrow $ runPlcCek values)
+
+goldenEvalCekLog :: ToUPlc a PLC.DefaultUni PLC.DefaultFun => String -> [a] -> TestNested
+goldenEvalCekLog name values = nestedGoldenVsDocM name $ pretty . view _1 <$> (rethrow $ runPlcCekTrace values)

plutus-tx-plugin/test/Plugin/Basic/Spec.hs

@@ -4,9 +4,9 @@
 {-# LANGUAGE TypeApplications    #-}
 {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
 
-
 module Plugin.Basic.Spec where
 
 import Common

plutus-tx-plugin/test/Plugin/Coverage/Spec.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
 {-# OPTIONS_GHC -fplugin PlutusTx.Plugin -fplugin-opt PlutusTx.Plugin:coverage-all #-}
-{-# OPTIONS_GHC -g #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
 
 module Plugin.Coverage.Spec (coverage) where
 

plutus-tx-plugin/test/Plugin/Data/Spec.hs

@@ -4,7 +4,10 @@
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
-{-# OPTIONS_GHC -fplugin PlutusTx.Plugin -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:no-context #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 

plutus-tx-plugin/test/Plugin/Errors/Spec.hs

@@ -4,7 +4,10 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
-{-# OPTIONS_GHC -fplugin PlutusTx.Plugin -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:no-context #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 
 module Plugin.Errors.Spec where

plutus-tx-plugin/test/Plugin/Functions/Spec.hs

@@ -4,7 +4,10 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE UnboxedTuples       #-}
-{-# OPTIONS_GHC -fplugin PlutusTx.Plugin -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:no-context #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 
 module Plugin.Functions.Spec where

plutus-tx-plugin/test/Plugin/Laziness/Spec.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeApplications    #-}
 {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-context #-}
 
 module Plugin.Laziness.Spec where

plutus-tx-plugin/test/Plugin/NoTrace/Spec.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-}
+
+module Plugin.NoTrace.Spec where
+
+import Common
+import Data.Proxy
+import Lib
+import Prelude qualified as H
+
+import PlutusTx
+import PlutusTx.Builtins qualified as B
+import PlutusTx.Plugin
+import PlutusTx.Prelude qualified as P
+
+noTrace :: TestNested
+noTrace = testNested "NoTrace"
+  [ goldenPir "trace" trace
+  , goldenPir "traceComplex" traceComplex
+  , goldenEvalCekLog "traceDirect" [traceDirect]
+  , goldenEvalCekLog "tracePrelude" [tracePrelude]
+  , goldenEvalCekLog "traceRepeatedly" [traceRepeatedly]
+  ]
+
+-- Half-stolen from Plugin.Primitives.Spec
+trace :: CompiledCode (B.BuiltinString -> ())
+trace = plc (Proxy @"trace") (\(x :: B.BuiltinString) -> B.trace x ())
+
+traceComplex :: CompiledCode (H.Bool -> ())
+traceComplex = plc (Proxy @"traceComplex") (\(b :: H.Bool) -> if b then P.trace "yes" () else P.traceError "no")
+
+-- Half-stolen from TH.Spec
+traceDirect :: CompiledCode ()
+traceDirect = $$(compile [|| B.trace "test" () ||])
+
+tracePrelude :: CompiledCode H.Integer
+tracePrelude = $$(compile [|| P.trace "test" (1::H.Integer) ||])
+
+traceRepeatedly :: CompiledCode P.Integer
+traceRepeatedly = $$(compile
+  [||
+    let i1 = P.trace "Making my first int" (1::P.Integer)
+        i2 = P.trace "Making my second int" (2::P.Integer)
+        i3 = P.trace "Adding them up" (i1 P.+ i2)
+    in i3
+  ||])

plutus-tx-plugin/test/Plugin/NoTrace/trace.plc.golden

@@ -0,0 +1,9 @@
+(program
+  (let
+    (nonrec)
+    (datatypebind
+      (datatype (tyvardecl Unit (type))  Unit_match (vardecl Unit Unit))
+    )
+    (lam ds (con string) Unit)
+  )
+)