PLT-8659 UPLC term order evaluator takes into account builtin argumen…

…t saturation (#5850)

* UPLC term order evaluator takes into account builtin argument saturation

* Use factual builtin arity when doing CSE

* Changelog entry

plutus-benchmark/lists/test/Lookup/9.6/match-builtin-list-10.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 282508764
-| mem: 856552})
+({cpu: 281818764
+| mem: 853552})

plutus-benchmark/lists/test/Lookup/9.6/match-builtin-list-100.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 23474602554
-| mem: 69678832})
+({cpu: 23467702554
+| mem: 69648832})

plutus-benchmark/lists/test/Lookup/9.6/match-builtin-list-5.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 85015834
-| mem: 263092})
+({cpu: 84670834
+| mem: 261592})

plutus-benchmark/lists/test/Lookup/9.6/match-builtin-list-50.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 5996604004
-| mem: 17844232})
+({cpu: 5993154004
+| mem: 17829232})

plutus-benchmark/lists/test/Lookup/9.6/match-scott-list-10.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 188350620
-| mem: 557080})
+({cpu: 187660620
+| mem: 554080})

plutus-benchmark/lists/test/Lookup/9.6/match-scott-list-100.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 14193534300
-| mem: 39720400})
+({cpu: 14186634300
+| mem: 39690400})

plutus-benchmark/lists/test/Lookup/9.6/match-scott-list-5.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 61018710
-| mem: 188240})
+({cpu: 60673710
+| mem: 186740})

plutus-benchmark/lists/test/Lookup/9.6/match-scott-list-50.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 3672944700
-| mem: 10355000})
+({cpu: 3669494700
+| mem: 10340000})

plutus-benchmark/marlowe/test/semantics/9.6/18cefc240debc0fcab14efdd451adfd02793093efe7bc76d6322aed6ddb582ad.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 951958685
-| mem: 3466381})
+({cpu: 951682685
+| mem: 3465181})

plutus-benchmark/marlowe/test/semantics/9.6/82213dfdb6a812b40446438767c61a388d2c0cfd0cbf7fd4a372b0dc59fa17e1.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 1499682480
-| mem: 4967076})
+({cpu: 1499268480
+| mem: 4965276})

plutus-core/changelog.d/20240326_133744_Yuriy.Lazaryev_term_eval_order_builtin.md

@@ -0,0 +1,3 @@
+### Changed
+
+- Partially applied builtins are estimated to be pure and work-free to better inform other optimizations, e.g. common subexpression elimination.

plutus-core/executables/pir/Main.hs

@@ -1,6 +1,5 @@
 -- editorconfig-checker-disable-file
 {-# LANGUAGE DeriveAnyClass    #-}
-{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TypeApplications  #-}
@@ -101,7 +100,7 @@ pOptimise :: Parser Bool
 pOptimise = flag True False
             (  long "dont-optimise"
             <> long "dont-optimize"
-            <> help ("Turn off optimisations")
+            <> help "Turn off optimisations"
             )
 
 pJustTest :: Parser Bool
@@ -133,7 +132,7 @@ pPirOptions = hsubparser $
                    "and test if it can be successfully compiled to PLC.")
            <> command "convert"
                   (info (Convert <$> pPirConvertOptions)
-                   (progDesc $ "Convert a program between textual and flat-named format."))
+                  (progDesc "Convert a program between textual and flat-named format."))
            <> command "optimise" (optimise "Run the PIR optimisation pipeline on the input.")
            <> command "optimize" (optimise "Same as 'optimise'.")
            <> command "print"
@@ -153,7 +152,7 @@ compileToPlc optimise p = do
     plcTcConfig <- PLC.getDefTypeCheckConfig PIR.noProvenance
     let ctx = getCtx plcTcConfig
     plcProg <- runExcept $ flip runReaderT ctx $ runQuoteT $ PIR.compileProgram p
-    pure $ () <$ plcProg
+    pure $ void plcProg
   where
     getCtx :: PLC.TypeCheckConfig PLC.DefaultUni PLC.DefaultFun
       -> PIR.CompilationCtx PLC.DefaultUni PLC.DefaultFun a
@@ -169,15 +168,16 @@ compileToUplc optimise plcProg =
     let plcCompilerOpts =
             if optimise
             then PLC.defaultCompilationOpts
-            else PLC.defaultCompilationOpts & PLC.coSimplifyOpts . UPLC.soMaxSimplifierIterations .~ 0
+            else PLC.defaultCompilationOpts
+                    & PLC.coSimplifyOpts . UPLC.soMaxSimplifierIterations .~ 0
     in flip runReader plcCompilerOpts $ runQuoteT $ PLC.compileProgram plcProg
 
 loadPirAndCompile :: CompileOptions -> IO ()
 loadPirAndCompile (CompileOptions language optimise test inp ifmt outp ofmt mode)  = do
     pirProg <- readProgram (pirFormatToFormat ifmt) inp
     when test $ putStrLn "!!! Compiling"
     -- Now compile to plc, maybe optimising
-    case compileToPlc optimise (() <$ pirProg) of
+    case compileToPlc optimise (void pirProg) of
       Left pirError -> error $ show pirError
       Right plcProg ->
           case language of
@@ -213,7 +213,7 @@ runOptimisations (PirOptimiseOptions inp ifmt outp ofmt mode) = do
   case doOptimisations term of
     Left e  -> error $ show e
     Right t -> writeProgram outp (pirFormatToFormat ofmt) mode
-               (Program () PLC.latestVersion(() <$ t))
+               (Program () PLC.latestVersion(void t))
 
 
 ---------------- Analysis ----------------
@@ -229,7 +229,7 @@ loadPirAndAnalyse :: AnalyseOptions -> IO ()
 loadPirAndAnalyse (AnalyseOptions inp ifmt outp) = do
     -- load pir and make sure that it is globally unique (required for retained size)
     p :: PirProg PLC.SrcSpan <- readProgram (pirFormatToFormat ifmt) inp
-    let PIR.Program _ _ term = PLC.runQuote . PLC.rename $ () <$ p
+    let PIR.Program _ _ term = PLC.runQuote . PLC.rename $ void p
     putStrLn "!!! Analysing for retention"
     let
         -- all the variable names (tynames coerced to names)

plutus-core/executables/uplc/Main.hs

@@ -251,21 +251,23 @@ plutusOpts = hsubparser $
 ---------------- Optimisation ----------------
 
 -- | Run the UPLC optimisations
-runOptimisations:: OptimiseOptions -> IO ()
+runOptimisations :: OptimiseOptions -> IO ()
 runOptimisations (OptimiseOptions inp ifmt outp ofmt mode) = do
-    prog <- readProgram ifmt inp :: IO (UplcProg SrcSpan)
-    simplified <- PLC.runQuoteT $ do
-                    renamed <- PLC.rename prog
-                    UPLC.simplifyProgram UPLC.defaultSimplifyOpts renamed
-    writeProgram outp ofmt mode simplified
+  prog <- readProgram ifmt inp :: IO (UplcProg SrcSpan)
+  simplified <- PLC.runQuoteT $ do
+    renamed <- PLC.rename prog
+    let defaultBuiltinSemanticsVariant :: BuiltinSemanticsVariant PLC.DefaultFun
+        defaultBuiltinSemanticsVariant = def
+    UPLC.simplifyProgram UPLC.defaultSimplifyOpts defaultBuiltinSemanticsVariant renamed
+  writeProgram outp ofmt mode simplified
 
 ---------------- Script application ----------------
 
 -- | Apply one script to a list of others and output the result.  All of the
 -- scripts must be UPLC.Program objects.
 runApply :: ApplyOptions -> IO ()
 runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do
-  scripts <- mapM ((readProgram ifmt ::  Input -> IO (UplcProg SrcSpan)) . FileInput) inputfiles
+  scripts <- mapM ((readProgram ifmt :: Input -> IO (UplcProg SrcSpan)) . FileInput) inputfiles
   let appliedScript =
         case void <$> scripts of
           []          -> errorWithoutStackTrace "No input files"
@@ -282,16 +284,15 @@ runApplyToData (ApplyOptions inputfiles ifmt outp ofmt mode) =
     p:ds -> do
          prog@(UPLC.Program _ version _) :: UplcProg SrcSpan <- readProgram ifmt (FileInput p)
          args <- mapM (getDataObject version) ds
-         let prog' = () <$ prog
+         let prog' = void prog
              appliedScript = foldl1 (unsafeFromRight .* UPLC.applyProgram) (prog':args)
          writeProgram outp ofmt mode appliedScript
              where getDataObject :: UPLC.Version -> FilePath -> IO (UplcProg ())
                    getDataObject ver path = do
                      bs <- BSL.readFile path
                      case unflat bs of
-                       Left err -> fail ("Error reading " ++ show path ++ ": " ++ show err)
-                       Right (d :: Data) ->
-                           pure $ UPLC.Program () ver $ mkConstant () d
+                       Left err          -> fail ("Error reading " ++ show path ++ ": " ++ show err)
+                       Right (d :: Data) -> pure $ UPLC.Program () ver $ mkConstant () d
 
 ---------------- Benchmarking ----------------
 
@@ -300,7 +301,7 @@ runBenchmark (BenchmarkOptions inp ifmt semvar timeLim) = do
   prog <- readProgram ifmt inp
   let criterionConfig = defaultConfig {reportFile = Nothing, timeLimit = timeLim}
       cekparams = mkMachineParameters semvar PLC.defaultCekCostModel
-      getResult (x,_,_) = either (error . show) (\_ -> ()) x  -- Extract an evaluation result
+      getResult (x,_,_) = either (error . show) (const ()) x  -- Extract an evaluation result
       evaluate = getResult . Cek.runCekDeBruijn cekparams Cek.restrictingEnormous Cek.noEmitter
       -- readProgam throws away De Bruijn indices and returns an AST with Names;
       -- we have to put them back to get an AST with NamedDeBruijn names.
@@ -309,7 +310,7 @@ runBenchmark (BenchmarkOptions inp ifmt semvar timeLim) = do
       -- Big names slow things down
       !anonTerm = UPLC.termMapNames (\(PLC.NamedDeBruijn _ i) -> PLC.NamedDeBruijn "" i) term
       -- Big annotations slow things down
-      !unitAnnTerm = force (() <$ anonTerm)
+      !unitAnnTerm = force (void anonTerm)
   benchmarkWith criterionConfig $! whnf evaluate unitAnnTerm
 
 ---------------- Evaluation ----------------

plutus-core/plutus-core.cabal

@@ -98,6 +98,7 @@ library
     PlutusCore.Check.Value
     PlutusCore.Compiler
     PlutusCore.Compiler.Erase
+    PlutusCore.Compiler.Opts
     PlutusCore.Compiler.Types
     PlutusCore.Core
     PlutusCore.Crypto.BLS12_381.Error
@@ -256,6 +257,7 @@ library
     UntypedPlutusCore.Mark
     UntypedPlutusCore.Rename.Internal
     UntypedPlutusCore.Simplify
+    UntypedPlutusCore.Simplify.Opts
     UntypedPlutusCore.Size
     UntypedPlutusCore.Subst
     UntypedPlutusCore.Transform.CaseOfCase

plutus-core/plutus-core/src/PlutusCore/Arity.hs

@@ -45,4 +45,4 @@ builtinArity
     -> Arity
 builtinArity _ semvar fun =
   case toBuiltinMeaning @uni @fun @(Term TyName Name uni fun ()) semvar fun of
-        BuiltinMeaning sch _ _ -> typeSchemeArity sch
+    BuiltinMeaning sch _ _ -> typeSchemeArity sch

plutus-core/plutus-core/src/PlutusCore/Compiler.hs

@@ -1,45 +1,36 @@
-{-# LANGUAGE TemplateHaskell #-}
-module PlutusCore.Compiler (
-    compileTerm
-    , compileProgram
-    , CompilationOpts (..)
-    , coSimplifyOpts
-    , defaultCompilationOpts
-    ) where
+module PlutusCore.Compiler
+  ( module Opts
+  , compileTerm
+  , compileProgram
+  ) where
 
 import PlutusCore.Compiler.Erase
 import PlutusCore.Compiler.Types
 import PlutusCore.Core
 import PlutusCore.Name.Unique
 import PlutusCore.Rename
-import UntypedPlutusCore.Core qualified as UPLC
+import UntypedPlutusCore.Core.Type qualified as UPLC
 import UntypedPlutusCore.Simplify qualified as UPLC
 
-import Control.Lens
-import Control.Monad.Reader
-
-newtype CompilationOpts name a = CompilationOpts { _coSimplifyOpts :: UPLC.SimplifyOpts name a }
-  deriving stock (Show)
-
-makeLenses ''CompilationOpts
-
-defaultCompilationOpts :: CompilationOpts name a
-defaultCompilationOpts = CompilationOpts { _coSimplifyOpts = UPLC.defaultSimplifyOpts }
+import Control.Lens (view)
+import Control.Monad.Reader (MonadReader)
+import PlutusCore.Compiler.Opts as Opts
 
 -- | Compile a PLC term to UPLC, and optimize it.
 compileTerm
-    :: (Compiling m uni fun name a, MonadReader (CompilationOpts name a) m)
-    => Term tyname name uni fun a
-    -> m (UPLC.Term name uni fun a)
+  :: (Compiling m uni fun name a, MonadReader (CompilationOpts name fun a) m)
+  => Term tyname name uni fun a
+  -> m (UPLC.Term name uni fun a)
 compileTerm t = do
-    simplOpts <- asks _coSimplifyOpts
-    let erased =  eraseTerm t
-    renamed <- rename erased
-    UPLC.simplifyTerm simplOpts renamed
+  simplOpts <- view coSimplifyOpts
+  builtinSemanticsVariant <- view coBuiltinSemanticsVariant
+  let erased = eraseTerm t
+  renamed <- rename erased
+  UPLC.simplifyTerm simplOpts builtinSemanticsVariant renamed
 
 -- | Compile a PLC program to UPLC, and optimize it.
 compileProgram
-    :: (Compiling m uni fun name a, MonadReader (CompilationOpts name a) m)
-    => Program tyname name uni fun a
-    -> m (UPLC.Program name uni fun a)
+  :: (Compiling m uni fun name a, MonadReader (CompilationOpts name fun a) m)
+  => Program tyname name uni fun a
+  -> m (UPLC.Program name uni fun a)
 compileProgram (Program a v t) = UPLC.Program a v <$> compileTerm t

plutus-core/plutus-core/src/PlutusCore/Compiler/Opts.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module PlutusCore.Compiler.Opts
+  ( CompilationOpts (..)
+  , coSimplifyOpts
+  , coBuiltinSemanticsVariant
+  , defaultCompilationOpts
+  ) where
+
+import Control.Lens (makeLenses)
+import Data.Default.Class (Default (def))
+import PlutusCore.Builtin.Meaning (BuiltinSemanticsVariant)
+import UntypedPlutusCore.Simplify.Opts (SimplifyOpts, defaultSimplifyOpts)
+
+data CompilationOpts name fun a = CompilationOpts
+  { _coSimplifyOpts            :: SimplifyOpts name a
+  , _coBuiltinSemanticsVariant :: BuiltinSemanticsVariant fun
+  }
+
+$(makeLenses ''CompilationOpts)
+
+defaultCompilationOpts :: (Default (BuiltinSemanticsVariant fun)) => CompilationOpts name fun a
+defaultCompilationOpts =
+  CompilationOpts
+    { _coSimplifyOpts = defaultSimplifyOpts
+    , _coBuiltinSemanticsVariant = def
+    }

plutus-core/plutus-ir/src/PlutusIR/Purity.hs

@@ -248,7 +248,7 @@ termEvaluationOrder binfo vinfo = goTerm
       -- TODO: previous definition of work-free included this, it's slightly
       -- unclear if we should do since we do update partial builtin meanings
       -- etc.
-      -- If it's unsaturated, we definitely don't, and don't do any work
+      -- If it's unsaturated, we definitely don't do any work
       Just Undersaturated -> pureWorkFree
       -- Don't know, be conservative
       Nothing             -> maybeImpureWork

plutus-core/testlib/PlutusCore/Test.hs

@@ -151,12 +151,15 @@ instance ToUPlc (UPLC.Program TPLC.Name uni fun ()) uni fun where
   toUPlc = pure
 
 instance
-    ( TPLC.Typecheckable uni fun
-    , Hashable fun
-    )
-    => ToUPlc (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) uni fun where
-    toUPlc =
-        pure . TPLC.runQuote . flip runReaderT TPLC.defaultCompilationOpts . TPLC.compileProgram
+  ( TPLC.Typecheckable uni fun
+  , Hashable fun
+  )
+  => ToUPlc (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) uni fun where
+  toUPlc =
+    pure
+      . TPLC.runQuote
+      . flip runReaderT TPLC.defaultCompilationOpts
+      . TPLC.compileProgram
 
 instance ToUPlc (UPLC.Program UPLC.NamedDeBruijn uni fun ()) uni fun where
   toUPlc p =
@@ -294,7 +297,7 @@ runUPlcProfile' values = do
       (res, UPLC.CountingSt _, logs) =
         UPLC.runCek TPLC.defaultCekParameters UPLC.counting UPLC.logWithBudgetEmitter t
   case res of
-    Left err -> throwError (SomeException $ err)
+    Left err -> throwError (SomeException err)
     Right _  -> pure logs
 
 ppCatch :: (PrettyPlc a) => ExceptT SomeException IO a -> IO (Doc ann)