[Costing] Provide support for multiple 'CostModel's (#5851)

plutus-benchmark/bls12-381-costs/bench/Bench.hs

@@ -11,7 +11,6 @@ import PlutusBenchmark.Common (benchProgramCek, mkEvalCtx)
 import PlutusLedgerApi.Common (EvaluationContext)
 import PlutusTx.Prelude qualified as Tx
 
-import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 import Data.ByteString qualified as BS (empty)
 
@@ -78,7 +77,7 @@ schnorrG2Verify ctx = bench "schnorrG2Verify" $ benchProgramCek ctx mkSchnorrG2V
 
 main :: IO ()
 main = do
-  evalCtx <- evaluate $ force mkEvalCtx
+  evalCtx <- evaluate mkEvalCtx
   defaultMain [
         bgroup "hashAndAddG1" $ fmap (benchHashAndAddG1 evalCtx) [0, 10..150]
       , bgroup "hashAndAddG2" $ fmap (benchHashAndAddG2 evalCtx) [0, 10..150]

plutus-benchmark/cek-calibration/Main.hs

@@ -26,7 +26,6 @@ import PlutusTx.Plugin ()
 import PlutusTx.Prelude as Tx
 import UntypedPlutusCore as UPLC
 
-import Control.DeepSeq (force)
 import Control.Exception
 import Control.Lens
 import Control.Monad.Except
@@ -88,7 +87,7 @@ writePlc p =
 
 main1 :: Haskell.IO ()
 main1 = do
-  evalCtx <- evaluate $ force mkEvalCtx
+  evalCtx <- evaluate mkEvalCtx
   defaultMainWith
       (defaultConfig { C.csvFile = Just "cek-lists.csv" })
       [mkListBMs evalCtx [0,10..1000]]

plutus-benchmark/common/PlutusBenchmark/Common.hs

@@ -162,7 +162,11 @@ mkEvalCtx =
         Just p ->
             let errOrCtx =
                     -- The validation benchmarks were all created from PlutusV1 scripts
-                    LedgerApi.mkDynEvaluationContext DefaultFunSemanticsVariant1 p
+                    LedgerApi.mkDynEvaluationContext
+                        LedgerApi.PlutusV1
+                        [DefaultFunSemanticsVariant1]
+                        (const DefaultFunSemanticsVariant1)
+                        p
             in case errOrCtx of
                 Right ec -> ec
                 Left err -> error $ show err

plutus-benchmark/lists/bench/Bench.hs

@@ -12,7 +12,6 @@ import PlutusBenchmark.Lists.Sum.Compiled qualified as Sum.Compiled
 import PlutusBenchmark.Lists.Sum.HandWritten qualified as Sum.HandWritten
 import PlutusLedgerApi.Common (EvaluationContext)
 
-import Control.DeepSeq
 import Control.Exception
 import Data.Functor
 
@@ -55,5 +54,5 @@ main :: IO ()
 main = do
   -- Run each benchmark for at least 15 seconds.  Change this with -L or --timeout.
   config <- getConfig 15.0
-  evalCtx <- evaluate $ force mkEvalCtx
+  evalCtx <- evaluate mkEvalCtx
   defaultMainWith config $ benchmarks evalCtx

plutus-benchmark/marlowe/bench/BenchCek.hs

@@ -5,10 +5,9 @@ module Main where
 import PlutusBenchmark.Common (benchProgramCek, mkEvalCtx)
 import Shared (runBenchmarks)
 
-import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 
 main :: IO ()
 main = do
-  evalCtx <- evaluate $ force mkEvalCtx
+  evalCtx <- evaluate mkEvalCtx
   runBenchmarks (benchProgramCek evalCtx)

plutus-benchmark/nofib/bench/BenchCek.hs

@@ -5,10 +5,9 @@ module Main where
 
 import Shared (benchTermCek, benchWith, mkEvalCtx)
 
-import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 
 main :: IO ()
 main = do
-  evalCtx <- evaluate $ force mkEvalCtx
+  evalCtx <- evaluate mkEvalCtx
   benchWith $ benchTermCek evalCtx

plutus-benchmark/plutus-benchmark.cabal

@@ -149,7 +149,6 @@ benchmark nofib
   build-depends:
     , base                     >=4.9     && <5
     , criterion                >=1.5.9.0
-    , deepseq
     , nofib-internal
     , plutus-benchmark-common
 
@@ -225,7 +224,6 @@ benchmark lists
   build-depends:
     , base                     >=4.9     && <5
     , criterion                >=1.5.9.0
-    , deepseq
     , lists-internal
     , plutus-benchmark-common
     , plutus-ledger-api        ^>=1.26
@@ -262,7 +260,6 @@ benchmark validation
     , base                     >=4.9     && <5
     , bytestring
     , criterion                >=1.5.9.0
-    , deepseq
     , directory
     , filepath
     , flat                     ^>=0.6
@@ -323,7 +320,6 @@ benchmark cek-calibration
   build-depends:
     , base                     >=4.9     && <5
     , criterion                >=1.5.9.0
-    , deepseq
     , lens
     , mtl
     , plutus-benchmark-common
@@ -425,7 +421,6 @@ benchmark bls12-381-benchmarks
     , bls12-381lib-internal
     , bytestring
     , criterion                >=1.5.9.0
-    , deepseq
     , plutus-benchmark-common
     , plutus-ledger-api        ^>=1.26
     , plutus-tx                ^>=1.26
@@ -518,7 +513,6 @@ benchmark marlowe
   build-depends:
     , base                     >=4.9   && <5
     , criterion
-    , deepseq
     , marlowe-internal
     , plutus-benchmark-common
     , plutus-ledger-api        ^>=1.26

plutus-benchmark/validation/bench/BenchCek.hs

@@ -2,7 +2,6 @@
 module Main where
 
 import Common (benchTermCek, benchWith, mkEvalCtx, unsafeUnflat)
-import Control.DeepSeq (force)
 import Control.Exception (evaluate)
 import PlutusBenchmark.Common (toNamedDeBruijnTerm)
 import UntypedPlutusCore as UPLC
@@ -17,7 +16,7 @@ import UntypedPlutusCore as UPLC
 -}
 main :: IO ()
 main = do
-  evalCtx <- evaluate $ force mkEvalCtx
+  evalCtx <- evaluate mkEvalCtx
   let mkCekBM file program =
           benchTermCek evalCtx . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program
   benchWith mkCekBM

plutus-benchmark/validation/bench/BenchFull.hs

@@ -23,7 +23,7 @@ the whole time taken from script deserialization to script execution result.
 -}
 main :: IO ()
 main = do
-    evalCtx <- evaluate $ force mkEvalCtx
+    evalCtx <- evaluate mkEvalCtx
     let mkFullBM :: FilePath -> BS.ByteString -> Benchmarkable
         mkFullBM file bsFlat =
             let UPLC.Program () ver body = unsafeUnflat file bsFlat

plutus-conformance/haskell/Spec.hs

@@ -12,9 +12,9 @@ import UntypedPlutusCore.Evaluation.Machine.Cek (CountingSt (..), counting, runC
 evalUplcProg :: UplcEvaluator
 evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) ->
     do
-        params <- case mkMachineParametersFor def modelParams of
-          Left _  -> Nothing
-          Right p -> Just p
+        params <- case mkMachineParametersFor [def] modelParams of
+          Left _               -> Nothing
+          Right machParamsList -> lookup def machParamsList
         -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with free variables,
         -- that is why we manually check first for any free vars
         case UPLC.deBruijnTerm t of

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

@@ -141,6 +141,7 @@ exampleOpts = ExampleOptions <$> exampleMode
 builtinSemanticsVariantReader :: String -> Maybe (BuiltinSemanticsVariant DefaultFun)
 builtinSemanticsVariantReader =
     \case
+     "0" -> Just DefaultFunSemanticsVariant0
      "1" -> Just DefaultFunSemanticsVariant1
      "2" -> Just DefaultFunSemanticsVariant2
      _   -> Nothing
@@ -149,6 +150,7 @@ builtinSemanticsVariantReader =
 showBuiltinSemanticsVariant :: BuiltinSemanticsVariant DefaultFun -> String
 showBuiltinSemanticsVariant =
     \case
+     DefaultFunSemanticsVariant0 -> "0"
      DefaultFunSemanticsVariant1 -> "1"
      DefaultFunSemanticsVariant2 -> "2"
 
@@ -160,7 +162,8 @@ builtinSemanticsVariant = option (maybeReader builtinSemanticsVariantReader)
   <> value DefaultFunSemanticsVariant2
   <> showDefaultWith showBuiltinSemanticsVariant
   <> help
-    ("Builtin semantics variant: 1 -> DefaultFunSemanticsVariant1, "
+    ("Builtin semantics variant: 0 -> DefaultFunSemanticsVariant0, "
+     <> "1 -> DefaultFunSemanticsVariant1"
      <> "2 -> DefaultFunSemanticsVariant2"
     )
   )

plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs

@@ -30,7 +30,6 @@ import PlutusCore.Evaluation.Machine.ExBudgetStream
 import PlutusCore.Evaluation.Machine.ExMemoryUsage
 import PlutusCore.Name.Unique
 
-import Control.DeepSeq
 import Data.Array
 import Data.Kind qualified as GHC
 import Data.Proxy
@@ -399,22 +398,15 @@ toBuiltinsRuntime
     -> cost
     -> BuiltinsRuntime fun val
 toBuiltinsRuntime semvar cost =
-    let runtime = BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar
-        -- This pragma is very important, removing it destroys the carefully set up optimizations of
-        -- of costing functions (see Note [Optimizations of runCostingFun*]). The reason for that is
-        -- that if @runtime@ doesn't have a pragma, then GHC sees that it's only referenced once and
-        -- inlines it below, together with this entire function (since we tell GHC to), at which
-        -- point everything's inlined and we're completely at GHC's mercy to optimize things
-        -- properly. Unfortunately, GHC doesn't want to cooperate and push 'toBuiltinRuntime' to
-        -- the inside of the inlined to 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's
-        -- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a
-        -- lambda binding the @cost@ variable, which renders all the optimizations useless. By
-        -- using a @NOINLINE@ pragma we tell GHC to create a separate thunk, which it can properly
-        -- optimize, because the other bazillion things don't get in the way.
-        {-# NOINLINE runtime #-}
-    in
-        -- Force each 'BuiltinRuntime' to WHNF, so that the thunk is allocated and forced at
-        -- initialization time rather than at runtime. Not that we'd lose much by not forcing all
-        -- 'BuiltinRuntime's here, but why pay even very little if there's an easy way not to pay.
-        force runtime
+    -- A call to 'lazy' is to make sure that the returned 'BuiltinsRuntime' is properly cached in a
+    -- 'let'-binding. This makes it easier for GHC to optimize the internals of builtins, because
+    -- without a 'let'-binding GHC would sometimes refuse to cooperate and push 'toBuiltinRuntime'
+    -- to the inside of the inlined 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's
+    -- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a lambda
+    -- binding the @cost@ variable, which makes the optimizations useless.
+    -- By using 'lazy' we tell GHC to create a separate thunk, which it can properly optimize,
+    -- because the other bazillion things don't get in the way. We used to use an explicit
+    -- 'let'-binding marked with @NOINLINE@, but that turned out to be unreliable, because GHC
+    -- feels free to turn it into a join point instead of a proper thunk.
+    lazy . BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar
 {-# INLINE toBuiltinsRuntime #-}

plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs

@@ -43,6 +43,7 @@ import Data.Text.Encoding (decodeUtf8', encodeUtf8)
 import Flat hiding (from, to)
 import Flat.Decoder (Get, dBEBits8)
 import Flat.Encoder as Flat (Encoding, NumBits, eBits)
+import NoThunks.Class (NoThunks)
 import Prettyprinter (viaShow)
 
 -- See Note [Pattern matching on built-in types].
@@ -1075,10 +1076,12 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
        possibly different semantics.  Note that DefaultFunSemanticsVariant1,
        DefaultFunSemanticsVariant1 etc. do not correspond directly to PlutusV1,
        PlutusV2 etc. in plutus-ledger-api: see Note [Builtin semantics variants]. -}
-    data BuiltinSemanticsVariant DefaultFun =
-              DefaultFunSemanticsVariant1
-            | DefaultFunSemanticsVariant2
-        deriving stock (Enum, Bounded, Show)
+    data BuiltinSemanticsVariant DefaultFun
+        = DefaultFunSemanticsVariant0
+        | DefaultFunSemanticsVariant1
+        | DefaultFunSemanticsVariant2
+        deriving stock (Eq, Enum, Bounded, Show, Generic)
+        deriving anyclass (NFData, NoThunks)
 
     -- Integers
     toBuiltinMeaning
@@ -1176,6 +1179,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
             appendByteStringDenotation
             (runCostingFunTwoArguments . paramAppendByteString)
 
+    -- See Note [Builtin semantics variants]
     toBuiltinMeaning semvar ConsByteString =
         -- The costing function is the same for all variants of this builtin,
         -- but since the denotation of the builtin accepts constants of
@@ -1185,26 +1189,26 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
                 :: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream
             costingFun = runCostingFunTwoArguments . paramConsByteString
             {-# INLINE costingFun #-}
-        -- See Note [Builtin semantics variants]
-        in case semvar of
-            DefaultFunSemanticsVariant1 ->
+            consByteStringMeaning_V1 =
                 let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString
                     consByteStringDenotation n xs = BS.cons (fromIntegral n) xs
                     {-# INLINE consByteStringDenotation #-}
                 in makeBuiltinMeaning
                     consByteStringDenotation
                     costingFun
-            -- For builtin semantics variants other (i.e. larger) than
-            -- DefaultFunSemanticsVariant1, the first input must be in range
-            -- [0..255].  See Note [How to add a built-in function: simple
-            -- cases]
-            DefaultFunSemanticsVariant2 ->
+            -- For builtin semantics variants larger than 'DefaultFunSemanticsVariant1', the first
+            -- input must be in range @[0..255]@.
+            consByteStringMeaning_V2 =
                 let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString
                     consByteStringDenotation = BS.cons
                     {-# INLINE consByteStringDenotation #-}
                 in makeBuiltinMeaning
                     consByteStringDenotation
                     costingFun
+        in case semvar of
+            DefaultFunSemanticsVariant0 -> consByteStringMeaning_V1
+            DefaultFunSemanticsVariant1 -> consByteStringMeaning_V1
+            DefaultFunSemanticsVariant2 -> consByteStringMeaning_V2
 
     toBuiltinMeaning _semvar SliceByteString =
         let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString
@@ -1287,7 +1291,8 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
                 :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool
             verifyEd25519SignatureDenotation =
                 case semvar of
-                  DefaultFunSemanticsVariant1 -> verifyEd25519Signature_V1
+                  DefaultFunSemanticsVariant0 -> verifyEd25519Signature_V1
+                  DefaultFunSemanticsVariant1 -> verifyEd25519Signature_V2
                   DefaultFunSemanticsVariant2 -> verifyEd25519Signature_V2
             {-# INLINE verifyEd25519SignatureDenotation #-}
         in makeBuiltinMeaning

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs

@@ -7,6 +7,7 @@ module PlutusCore.Evaluation.Machine.ExBudgetingDefaults
     ( defaultBuiltinsRuntimeForSemanticsVariant
     , defaultBuiltinsRuntime
     , defaultCekCostModel
+    , toCekCostModel
     , defaultCekMachineCosts
     , defaultCekParameters
     , defaultCostModelParams
@@ -85,6 +86,11 @@ defaultCekMachineCosts =
 defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel
 defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel
 
+-- | Return the 'CostModel' corresponding to the given semantics variant. The dependency on the
+-- semantics variant is what makes cost models configurable.
+toCekCostModel :: BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel
+toCekCostModel _ = defaultCekCostModel
+
 -- | The default cost model data.  This is exposed to the ledger, so let's not
 -- confuse anybody by mentioning the CEK machine
 defaultCostModelParams :: Maybe CostModelParams

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs

@@ -3,13 +3,16 @@
 -- we need to be able to visually inspect, hence we dedicate a separate file to it.
 module PlutusCore.Evaluation.Machine.MachineParameters.Default where
 
+import PlutusPrelude
+
 import PlutusCore.Builtin
 import PlutusCore.Default
 import PlutusCore.Evaluation.Machine.CostModelInterface
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
 import PlutusCore.Evaluation.Machine.MachineParameters
 import UntypedPlutusCore.Evaluation.Machine.Cek
 
+import Control.DeepSeq (force)
 import Control.Monad.Except
 import GHC.Exts (inline)
 
@@ -41,8 +44,9 @@ as we did have cases where sticking 'inline' on something that already had @INLI
 inlining).
 -}
 
--- | Produce a 'DefaultMachineParameters' given the version of the default set of built-in functions
--- and a 'CostModelParams', which gets applied on top of 'defaultCekCostModel'.
+-- | Produce a 'DefaultMachineParameters' for each of the given semantics variants.
+-- The 'CostModelParams' argument is used to update the costing parameters returned by
+-- 'toCekCostModel' for each of the semantics variants.
 --
 -- Whenever you need to evaluate UPLC in a performance-sensitive manner (e.g. in the production,
 -- for benchmarking, for cost calibration etc), you MUST use this definition for creating a
@@ -53,16 +57,21 @@ inlining).
 -- Core; you change how it's exported (implicitly as a part of a whole-module export or explicitly
 -- as a single definition) -- you get the idea.
 --
--- This function is expensive, so its result needs to be cached if it's going to be used multiple
--- times.
+-- This function is very expensive, so its result needs to be cached if it's going to be used
+-- multiple times.
 mkMachineParametersFor
     :: MonadError CostModelApplyError m
-    => BuiltinSemanticsVariant DefaultFun
+    => [BuiltinSemanticsVariant DefaultFun]
     -> CostModelParams
-    -> m DefaultMachineParameters
-mkMachineParametersFor semvar newCMP =
-    inline mkMachineParameters semvar <$>
-        applyCostModelParams defaultCekCostModel newCMP
+    -> m [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
+mkMachineParametersFor semVars newCMP = do
+    res <- for semVars $ \semVar ->
+        -- See Note [Inlining meanings of builtins].
+        (,) semVar . inline mkMachineParameters semVar <$>
+            applyCostModelParams (toCekCostModel semVar) newCMP
+    -- Force all thunks to pay the cost of creating machine parameters upfront. Doing it here saves
+    -- us from doing that in every single benchmark runner.
+    pure $! force res
 -- Not marking this function with @INLINE@, since at this point everything we wanted to be inlined
 -- is inlined and there's zero reason to duplicate thousands and thousands of lines of Core down
 -- the line.