[Costing] Provide support for multiple 'CostModel's

plutus-benchmark/common/PlutusBenchmark/Common.hs

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

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
+        params <- case mkMachineParametersFor [def] (const def) modelParams of
           Left _  -> Nothing
-          Right p -> Just p
+          Right p -> p ()
         -- 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,5 @@ 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
+    lazy . BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar
 {-# INLINE toBuiltinsRuntime #-}

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

@@ -1075,10 +1075,11 @@ 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)
 
     -- Integers
     toBuiltinMeaning
@@ -1176,6 +1177,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 +1187,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 +1289,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,9 @@ defaultCekMachineCosts =
 defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel
 defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel
 
+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.hs

@@ -14,7 +14,6 @@ import Control.DeepSeq
 import Control.Lens
 import GHC.Exts (inline)
 import GHC.Generics
-import NoThunks.Class
 
 {-| We need to account for the costs of evaluator steps and also built-in function
    evaluation.  The models for these have different structures and are used in
@@ -44,11 +43,6 @@ data MachineParameters machinecosts fun val =
     deriving stock Generic
     deriving anyclass (NFData)
 
--- For some reason the generic instance gives incorrect nothunk errors,
--- see https://github.com/input-output-hk/nothunks/issues/24
-instance (NoThunks machinecosts, Bounded fun, Enum fun) => NoThunks (MachineParameters machinecosts fun val) where
-  wNoThunks ctx (MachineParameters costs runtime) = allNoThunks [ noThunks ctx costs, noThunks ctx runtime ]
-
 {- Note [The CostingPart constraint in mkMachineParameters]
 Discharging the @CostingPart uni fun ~ builtincosts@ constraint in 'mkMachineParameters' causes GHC
 to fail to inline the function at its call site regardless of the @INLINE@ pragma and an explicit
@@ -86,6 +80,6 @@ mkMachineParameters ::
     => BuiltinSemanticsVariant fun
     -> CostModel machinecosts builtincosts
     -> MachineParameters machinecosts fun val
-mkMachineParameters semvar (CostModel mchnCosts builtinCosts) =
-    MachineParameters mchnCosts (inline toBuiltinsRuntime semvar builtinCosts)
+mkMachineParameters semVar (CostModel mchnCosts builtinCosts) =
+    MachineParameters mchnCosts (inline toBuiltinsRuntime semVar builtinCosts)
 {-# INLINE mkMachineParameters #-}

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

@@ -1,8 +1,12 @@
+{-# LANGUAGE BangPatterns #-}
+
 -- | Defines the type of default machine parameters and a function for creating a value of the type.
 -- We keep them separate, because the function unfolds into multiple thousands of lines of Core that
 -- 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
@@ -56,13 +60,16 @@ inlining).
 -- This function is expensive, so its result needs to be cached if it's going to be used multiple
 -- times.
 mkMachineParametersFor
-    :: MonadError CostModelApplyError m
-    => BuiltinSemanticsVariant DefaultFun
+    :: forall m a. MonadError CostModelApplyError m
+    => [BuiltinSemanticsVariant DefaultFun]
+    -> (a -> BuiltinSemanticsVariant DefaultFun)
     -> CostModelParams
-    -> m DefaultMachineParameters
-mkMachineParametersFor semvar newCMP =
-    inline mkMachineParameters semvar <$>
-        applyCostModelParams defaultCekCostModel newCMP
+    -> m (a -> Maybe DefaultMachineParameters)
+mkMachineParametersFor semVars toSemVar newCMP = do
+    semVarAndMachineParametersCache <- for semVars $ \semVar ->
+        (,) semVar . inline mkMachineParameters semVar <$>
+            applyCostModelParams (toCekCostModel semVar) newCMP
+    pure $ \x -> lookup (toSemVar x) semVarAndMachineParametersCache
 -- 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.

plutus-core/testlib/PlutusIR/Pass/Test.hs

@@ -4,14 +4,10 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 module PlutusIR.Pass.Test where
 
-import Control.Exception (throw)
 import Control.Monad.Except
-import Data.Bifunctor (first)
-import Data.Functor (void)
 import Data.Typeable
 import PlutusCore qualified as PLC
 import PlutusCore.Builtin
-import PlutusCore.Default (BuiltinSemanticsVariant (..))
 import PlutusCore.Generators.QuickCheck (forAllDoc)
 import PlutusCore.Pretty qualified as PLC
 import PlutusIR.Core.Type
@@ -20,6 +16,7 @@ import PlutusIR.Generators.QuickCheck
 import PlutusIR.Pass
 import PlutusIR.TypeCheck
 import PlutusIR.TypeCheck qualified as TC
+import PlutusPrelude
 import Test.QuickCheck
 
 -- Convert Either Error () to Either String () to match with the Testable (Either String ())
@@ -31,7 +28,7 @@ convertToEitherString = \case
   Right () -> Right ()
 
 instance Arbitrary (BuiltinSemanticsVariant PLC.DefaultFun) where
-    arbitrary = elements [DefaultFunSemanticsVariant1, DefaultFunSemanticsVariant2]
+    arbitrary = elements enumerate
 
 -- | An appropriate number of tests for a compiler pass property, so that we get some decent
 -- exploration of the program space. If you also take other arguments, then consider multiplying

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

@@ -43,7 +43,8 @@ module UntypedPlutusCore.Evaluation.Machine.Cek
     , logWithTimeEmitter
     , logWithBudgetEmitter
     -- * Misc
-    , CekValue(..)
+    , BuiltinsRuntime (..)
+    , CekValue (..)
     , readKnownCek
     , Hashable
     , ThrowableBuiltins

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs

@@ -42,8 +42,9 @@ import PlutusCore.StdLib.Data.Unit
 import Evaluation.Builtins.BLS12_381 (test_BLS12_381)
 import Evaluation.Builtins.Common
 import Evaluation.Builtins.Conversion qualified as Conversion
-import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_Variant1Prop,
-                                                  ed25519_Variant2Prop, schnorrSecp256k1Prop)
+import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_Variant0Prop,
+                                                  ed25519_Variant1Prop, ed25519_Variant2Prop,
+                                                  schnorrSecp256k1Prop)
 
 
 import Control.Exception
@@ -770,6 +771,8 @@ test_ConsByteString =
                              + 33 -- the index of '!' in ascii table
             expr1 = mkIterAppNoAnn (builtin () (Left ConsByteString :: DefaultFunExt))
                     [cons @Integer asciiBangWrapped, cons @ByteString "hello world"]
+        Right (EvaluationSuccess $ cons @ByteString "!hello world")  @=?
+              typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant0 def) defaultBuiltinCostModelExt expr1
         Right (EvaluationSuccess $ cons @ByteString "!hello world")  @=?
               typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant1 def) defaultBuiltinCostModelExt expr1
         Right EvaluationFailure @=? typecheckEvaluateCekNoEmit
@@ -802,6 +805,12 @@ test_SignatureVerification :: TestTree
 test_SignatureVerification =
   adjustOption (\x -> max x . HedgehogTestLimit . Just $ 8000) .
   testGroup "Signature verification" $ [
+        testGroup "Ed25519 signatures (Variant0)"
+                      [ testPropertyNamed
+                        "Ed25519_Variant0 verification behaves correctly on all inputs"
+                        "ed25519_Variant0_correct"
+                        . property $ ed25519_Variant0Prop
+                      ],
         testGroup "Ed25519 signatures (Variant1)"
                       [ testPropertyNamed
                         "Ed25519_Variant1 verification behaves correctly on all inputs"

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs

@@ -10,6 +10,7 @@
 
 module Evaluation.Builtins.SignatureVerification (
   ecdsaSecp256k1Prop,
+  ed25519_Variant0Prop,
   ed25519_Variant1Prop,
   ed25519_Variant2Prop,
   schnorrSecp256k1Prop,
@@ -75,6 +76,9 @@ ed25519Prop semvar = do
   cover 18 "happy path" . is (_Shouldn'tError . _AllGood) $ testCase
   runTestDataWith semvar testCase id VerifyEd25519Signature
 
+ed25519_Variant0Prop :: PropertyT IO ()
+ed25519_Variant0Prop = ed25519Prop DefaultFunSemanticsVariant0
+
 ed25519_Variant1Prop :: PropertyT IO ()
 ed25519_Variant1Prop = ed25519Prop DefaultFunSemanticsVariant1
 

plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs

@@ -106,14 +106,14 @@ mkTermToEvaluate ll pv script args = do
     through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT
 
 toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters
-toMachineParameters _ = machineParameters
+toMachineParameters pv ctx = machineParameters ctx pv
 
 {-| An opaque type that contains all the static parameters that the evaluator needs to evaluate a
 script.  This is so that they can be computed once and cached, rather than being recomputed on every
 evaluation.
 -}
 newtype EvaluationContext = EvaluationContext
-    { machineParameters :: DefaultMachineParameters
+    { machineParameters :: MajorProtocolVersion -> DefaultMachineParameters
     }
     deriving stock Generic
     deriving anyclass (NFData, NoThunks)
@@ -128,11 +128,18 @@ with the updated cost model parameters.
 -}
 mkDynEvaluationContext
     :: MonadError CostModelApplyError m
-    => BuiltinSemanticsVariant DefaultFun
+    => String
+    -> [BuiltinSemanticsVariant DefaultFun]
+    -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun)
     -> Plutus.CostModelParams
     -> m EvaluationContext
-mkDynEvaluationContext semvar newCMP =
-    EvaluationContext <$> mkMachineParametersFor semvar newCMP
+mkDynEvaluationContext lv semVars toSemVar newCMP =
+    mkMachineParametersFor semVars toSemVar newCMP <&> \getMachPars ->
+        EvaluationContext $ \pv ->
+            case getMachPars pv of
+                Nothing -> error $ Prelude.concat
+                    ["Internal error: ", show lv, " does not support ", show pv]
+                Just machPars -> machPars
 
 -- FIXME: remove this function
 assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m ()