From 49db6d5009629f14203b14e18e48d54bb14e537e Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 27 Feb 2024 03:42:49 +0100 Subject: [PATCH 01/29] [Builtins] Store 'BuiltinRuntime' lazily explicitly --- .../examples/PlutusCore/Examples/Builtins.hs | 4 ++-- .../src/PlutusCore/Builtin/Meaning.hs | 14 ++++++++------ .../src/PlutusCore/Builtin/Runtime.hs | 17 +++++++++++------ .../src/PlutusIR/Transform/EvaluateBuiltins.hs | 4 +++- 4 files changed, 24 insertions(+), 15 deletions(-) diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs index 413b0c4135d..925950cc6eb 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs @@ -151,10 +151,10 @@ instance (ToBuiltinMeaning uni fun1, ToBuiltinMeaning uni fun2 PairV (BuiltinSemanticsVariant fun1) (BuiltinSemanticsVariant fun2) toBuiltinMeaning (PairV semvarL _) (Left fun) = case toBuiltinMeaning semvarL fun of BuiltinMeaning tySch toF denot -> - BuiltinMeaning tySch toF (denot . fst) + BuiltinMeaning tySch toF $ \(cost, _) -> denot cost toBuiltinMeaning (PairV _ semvarR) (Right fun) = case toBuiltinMeaning semvarR fun of BuiltinMeaning tySch toF denot -> - BuiltinMeaning tySch toF (denot . snd) + BuiltinMeaning tySch toF $ \(_, cost) -> denot cost instance (Default (BuiltinSemanticsVariant fun1), Default (BuiltinSemanticsVariant fun2)) => Default (BuiltinSemanticsVariant (Either fun1 fun2)) where diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index aed5d9f618c..c4c37c2e778 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StrictData #-} @@ -35,7 +36,7 @@ import Data.Array import Data.Kind qualified as GHC import Data.Proxy import Data.Some.GADT -import GHC.Exts (inline, lazy, oneShot) +import GHC.Exts (inline, oneShot) import GHC.TypeLits -- | Turn a list of Haskell types @args@ into a functional type ending in @res@. @@ -64,7 +65,7 @@ data BuiltinMeaning val cost = forall args res. BuiltinMeaning (TypeScheme val args res) ~(FoldArgs args res) - (cost -> BuiltinRuntime val) + (cost -> (# BuiltinRuntime val #)) -- | Constraints available when defining a built-in function. type HasMeaningIn uni val = (Typeable val, ExMemoryUsage val, HasConstantIn uni val) @@ -380,13 +381,13 @@ instance -- Those thunks however require a lot of care to be properly shared rather than -- recreated every time a builtin application is evaluated, see 'toBuiltinsRuntime' for -- how we sort it out. - lazy $ case toExF cost of + (# case toExF cost of -- See Note [Optimizations of runCostingFun*] for why we use strict @case@. - !exF -> toPolyF @binds @val @args @res $ pure (f, exF) + !exF -> toPolyF @binds @val @args @res $ pure (f, exF) #) {-# INLINE makeBuiltinMeaning #-} -- | Convert a 'BuiltinMeaning' to a 'BuiltinRuntime' given a cost model. -toBuiltinRuntime :: cost -> BuiltinMeaning val cost -> BuiltinRuntime val +toBuiltinRuntime :: cost -> BuiltinMeaning val cost -> (# BuiltinRuntime val #) toBuiltinRuntime cost (BuiltinMeaning _ _ denot) = denot cost {-# INLINE toBuiltinRuntime #-} @@ -399,7 +400,8 @@ toBuiltinsRuntime -> cost -> BuiltinsRuntime fun val toBuiltinsRuntime semvar cost = - let runtime = BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar + let runtime = BuiltinsRuntime $ \fun -> + toBuiltinRuntime cost $ inline toBuiltinMeaning semvar fun -- 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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs index a77378a4218..872053356fd 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE StrictData #-} module PlutusCore.Builtin.Runtime where @@ -10,6 +12,7 @@ import PlutusCore.Builtin.KnownType import PlutusCore.Evaluation.Machine.ExBudgetStream import Control.DeepSeq +import GHC.Magic (noinline) import NoThunks.Class -- | A 'BuiltinRuntime' represents a possibly partial builtin application, including an empty @@ -64,21 +67,23 @@ instance NFData (BuiltinRuntime val) where -- In order for lookups to be efficient the 'BuiltinRuntime's need to be cached, i.e. pulled out -- of the function statically. See 'makeBuiltinMeaning' for how we achieve that. data BuiltinsRuntime fun val = BuiltinsRuntime - { unBuiltinsRuntime :: fun -> BuiltinRuntime val + { unBuiltinsRuntime :: fun -> (# BuiltinRuntime val #) } instance (Bounded fun, Enum fun) => NFData (BuiltinsRuntime fun val) where -- Force every 'BuiltinRuntime' stored in the environment. - rnf (BuiltinsRuntime env) = foldr (\fun res -> env fun `seq` res) () enumerate + rnf (BuiltinsRuntime env) = + foldr (\fun res -> case noinline env fun of (# runtime #) -> runtime `seq` res) () enumerate instance (Bounded fun, Enum fun) => NoThunks (BuiltinsRuntime fun val) where -- Ensure that every 'BuiltinRuntime' doesn't contain thunks after forcing it initially -- (we can't avoid the initial forcing, because we can't lookup the 'BuiltinRuntime' without -- forcing it, see https://stackoverflow.com/q/63441862). - wNoThunks ctx (BuiltinsRuntime env) = allNoThunks $ map (wNoThunks ctx . env) enumerate + wNoThunks ctx (BuiltinsRuntime env) = + allNoThunks $ map (\fun -> case env fun of (# runtime #) -> noThunks ctx runtime) enumerate showTypeOf = const "PlutusCore.Builtin.Runtime.BuiltinsRuntime" -- | Look up the runtime info of a built-in function during evaluation. lookupBuiltin :: fun -> BuiltinsRuntime fun val -> BuiltinRuntime val -lookupBuiltin fun (BuiltinsRuntime env) = env fun +lookupBuiltin fun (BuiltinsRuntime env) = case env fun of (# runtime #) -> runtime {-# INLINE lookupBuiltin #-} diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs index 01a0c4021ce..17879141bce 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-} -- | A pass that tries to evaluate builtin applications in the program. -- @@ -79,7 +80,8 @@ evaluateBuiltins conservative binfo costModel = transformOf termSubterms process processTerm :: Term tyname name uni fun a -> Term tyname name uni fun a -- See Note [Context splitting in a recursive pass] processTerm t@(splitApplication -> (Builtin x bn, argCtx)) = - let runtime = toBuiltinRuntime costModel (toBuiltinMeaning (binfo ^. biSemanticsVariant) bn) + let (# runtime #) = + toBuiltinRuntime costModel (toBuiltinMeaning (binfo ^. biSemanticsVariant) bn) in case eval runtime argCtx of -- Builtin evaluation gives us a fresh term with no annotation. -- Use the annotation of the builtin node, arbitrarily. This is slightly From e1d60b69843f502c3ed642c6cd439be17bdbf818 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 27 Feb 2024 20:01:55 +0100 Subject: [PATCH 02/29] An additional variant --- .../src/PlutusCore/Executable/Parsers.hs | 5 ++- .../src/PlutusCore/Builtin/Meaning.hs | 3 +- .../src/PlutusCore/Default/Builtins.hs | 42 +++++++++++-------- .../Machine/MachineParameters/Default.hs | 8 ++-- plutus-core/testlib/PlutusIR/Pass/Test.hs | 6 +-- .../test/Evaluation/Builtins/Definition.hs | 13 ++++-- .../Builtins/SignatureVerification.hs | 5 ++- .../src/PlutusLedgerApi/Common/Eval.hs | 10 ++--- .../PlutusLedgerApi/V1/EvaluationContext.hs | 14 +++++-- .../PlutusLedgerApi/V2/EvaluationContext.hs | 14 +++++-- .../PlutusLedgerApi/V3/EvaluationContext.hs | 2 +- 11 files changed, 75 insertions(+), 47 deletions(-) diff --git a/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs b/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs index 46e50c4e992..5a99d3f1a30 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs +++ b/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" ) ) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index c4c37c2e778..2981bfe3f0b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -31,7 +31,6 @@ import PlutusCore.Evaluation.Machine.ExBudgetStream import PlutusCore.Evaluation.Machine.ExMemoryUsage import PlutusCore.Name -import Control.DeepSeq import Data.Array import Data.Kind qualified as GHC import Data.Proxy @@ -418,5 +417,5 @@ toBuiltinsRuntime semvar cost = -- 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 + runtime {-# INLINE toBuiltinsRuntime #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index e783e7d41e3..75b47d3ecf4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1076,10 +1076,12 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where DefaultFunSemanticsVariant1 etc. do not correspond directly to PlutusV1, PlutusV2 etc. in plutus-ledger-api: see Note [Builtin semantics variants]. -} data BuiltinSemanticsVariant DefaultFun = - DefaultFunSemanticsVariant1 - | DefaultFunSemanticsVariant2 + DefaultFunSemanticsVariant0 + | DefaultFunSemanticsVariant1 + | DefaultFunSemanticsVariant2 deriving stock (Enum, Bounded, Show) + -- Integers toBuiltinMeaning :: forall val. HasMeaningIn uni val @@ -1186,25 +1188,28 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where costingFun = runCostingFunTwoArguments . paramConsByteString {-# INLINE costingFun #-} -- See Note [Builtin semantics variants] + originalDenotation = + let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString + consByteStringDenotation n xs = BS.cons (fromIntegral n) xs + {-# INLINE consByteStringDenotation #-} + in makeBuiltinMeaning + consByteStringDenotation + costingFun + newDenotation = + let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString + consByteStringDenotation = BS.cons + {-# INLINE consByteStringDenotation #-} + in makeBuiltinMeaning + consByteStringDenotation + costingFun in case semvar of - DefaultFunSemanticsVariant1 -> - 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 + DefaultFunSemanticsVariant0 -> originalDenotation + DefaultFunSemanticsVariant1 -> originalDenotation + -- 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 -> - let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString - consByteStringDenotation = BS.cons - {-# INLINE consByteStringDenotation #-} - in makeBuiltinMeaning - consByteStringDenotation - costingFun + DefaultFunSemanticsVariant2 -> newDenotation toBuiltinMeaning _semvar SliceByteString = let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString @@ -1287,7 +1292,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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 0c9c2d6edeb..e86e12f679b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -57,11 +57,11 @@ inlining). -- times. mkMachineParametersFor :: MonadError CostModelApplyError m - => BuiltinSemanticsVariant DefaultFun + => (a -> BuiltinSemanticsVariant DefaultFun) -> CostModelParams - -> m DefaultMachineParameters -mkMachineParametersFor semvar newCMP = - inline mkMachineParameters semvar <$> + -> m (a -> DefaultMachineParameters) +mkMachineParametersFor toSemVar newCMP = + (\cost x -> inline mkMachineParameters (toSemVar x) cost) <$> applyCostModelParams defaultCekCostModel newCMP -- 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 diff --git a/plutus-core/testlib/PlutusIR/Pass/Test.hs b/plutus-core/testlib/PlutusIR/Pass/Test.hs index 0a0a2b27b38..a507dd9829e 100644 --- a/plutus-core/testlib/PlutusIR/Pass/Test.hs +++ b/plutus-core/testlib/PlutusIR/Pass/Test.hs @@ -4,14 +4,11 @@ {-# OPTIONS_GHC -Wno-orphans #-} module PlutusIR.Pass.Test where -import Control.Exception (throw) import Control.Monad.Except -import Data.Bifunctor (first) import Data.Functor 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 +17,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 +29,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 diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index cc351bf22f1..c4f6018d2e9 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/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 @@ -771,7 +772,7 @@ test_ConsByteString = expr1 = mkIterAppNoAnn (builtin () (Left ConsByteString :: DefaultFunExt)) [cons @Integer asciiBangWrapped, cons @ByteString "hello world"] Right (EvaluationSuccess $ cons @ByteString "!hello world") @=? - typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant1 def) defaultBuiltinCostModelExt expr1 + typecheckEvaluateCekNoEmit (PairV (DefaultFunSemanticsVariant0) def) defaultBuiltinCostModelExt expr1 Right EvaluationFailure @=? typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant2 def) defaultBuiltinCostModelExt expr1 Right EvaluationFailure @=? @@ -802,6 +803,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" diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs index b9659dd0ac5..5715b3f94d8 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs @@ -75,8 +75,11 @@ 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 +ed25519_Variant1Prop = ed25519Prop (DefaultFunSemanticsVariant1) ed25519_Variant2Prop :: PropertyT IO () ed25519_Variant2Prop = ed25519Prop DefaultFunSemanticsVariant2 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index dbbe25f9cd0..3e710e759af 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/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,11 @@ with the updated cost model parameters. -} mkDynEvaluationContext :: MonadError CostModelApplyError m - => BuiltinSemanticsVariant DefaultFun + => (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> Plutus.CostModelParams -> m EvaluationContext -mkDynEvaluationContext semvar newCMP = - EvaluationContext <$> mkMachineParametersFor semvar newCMP +mkDynEvaluationContext toSemVar newCMP = + EvaluationContext <$> mkMachineParametersFor toSemVar newCMP -- FIXME: remove this function assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m () diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index f5474d8af7a..518a5abbf05 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V1.EvaluationContext ( EvaluationContext @@ -9,9 +10,10 @@ module PlutusLedgerApi.V1.EvaluationContext ) where import PlutusLedgerApi.Common +import PlutusLedgerApi.Common.Versions (conwayPV) import PlutusLedgerApi.V1.ParamName as V1 -import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant1)) +import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) import Control.Monad import Control.Monad.Except @@ -32,6 +34,10 @@ a protocol update with the updated cost model parameters. mkEvaluationContext :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => [Integer] -- ^ the (updated) cost model parameters of the protocol -> m EvaluationContext -mkEvaluationContext = tagWithParamNames @V1.ParamName - >=> pure . toCostModelParams - >=> mkDynEvaluationContext Plutus.DefaultFunSemanticsVariant1 +mkEvaluationContext = + tagWithParamNames @V1.ParamName + >=> pure . toCostModelParams + >=> mkDynEvaluationContext + (\pv -> if pv < conwayPV + then DefaultFunSemanticsVariant0 + else DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 104600affac..653d88cc5d2 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V2.EvaluationContext ( EvaluationContext @@ -9,9 +10,10 @@ module PlutusLedgerApi.V2.EvaluationContext ) where import PlutusLedgerApi.Common +import PlutusLedgerApi.Common.Versions (conwayPV) import PlutusLedgerApi.V2.ParamName as V2 -import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant1)) +import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) import Control.Monad import Control.Monad.Except @@ -32,6 +34,10 @@ a protocol update with the updated cost model parameters. mkEvaluationContext :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => [Integer] -- ^ the (updated) cost model parameters of the protocol -> m EvaluationContext -mkEvaluationContext = tagWithParamNames @V2.ParamName - >=> pure . toCostModelParams - >=> mkDynEvaluationContext Plutus.DefaultFunSemanticsVariant1 +mkEvaluationContext = + tagWithParamNames @V2.ParamName + >=> pure . toCostModelParams + >=> mkDynEvaluationContext + (\pv -> if pv < conwayPV + then Plutus.DefaultFunSemanticsVariant0 + else Plutus.DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index b8f364df29e..24aa8b15be3 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -34,4 +34,4 @@ mkEvaluationContext :: (MonadError CostModelApplyError m, MonadWriter [CostModel -> m EvaluationContext mkEvaluationContext = tagWithParamNames @V3.ParamName >=> pure . toCostModelParams - >=> mkDynEvaluationContext Plutus.DefaultFunSemanticsVariant2 + >=> mkDynEvaluationContext (const Plutus.DefaultFunSemanticsVariant2) From 3c400233757b3065c6531e8553e6344c8b64d361 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 27 Feb 2024 20:02:19 +0100 Subject: [PATCH 03/29] Revert "[Builtins] Store 'BuiltinRuntime' lazily explicitly" This reverts commit 49db6d5009629f14203b14e18e48d54bb14e537e. --- .../examples/PlutusCore/Examples/Builtins.hs | 4 ++-- .../src/PlutusCore/Builtin/Meaning.hs | 14 ++++++-------- .../src/PlutusCore/Builtin/Runtime.hs | 17 ++++++----------- .../src/PlutusIR/Transform/EvaluateBuiltins.hs | 4 +--- 4 files changed, 15 insertions(+), 24 deletions(-) diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs index 925950cc6eb..413b0c4135d 100644 --- a/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs +++ b/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs @@ -151,10 +151,10 @@ instance (ToBuiltinMeaning uni fun1, ToBuiltinMeaning uni fun2 PairV (BuiltinSemanticsVariant fun1) (BuiltinSemanticsVariant fun2) toBuiltinMeaning (PairV semvarL _) (Left fun) = case toBuiltinMeaning semvarL fun of BuiltinMeaning tySch toF denot -> - BuiltinMeaning tySch toF $ \(cost, _) -> denot cost + BuiltinMeaning tySch toF (denot . fst) toBuiltinMeaning (PairV _ semvarR) (Right fun) = case toBuiltinMeaning semvarR fun of BuiltinMeaning tySch toF denot -> - BuiltinMeaning tySch toF $ \(_, cost) -> denot cost + BuiltinMeaning tySch toF (denot . snd) instance (Default (BuiltinSemanticsVariant fun1), Default (BuiltinSemanticsVariant fun2)) => Default (BuiltinSemanticsVariant (Either fun1 fun2)) where diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index 2981bfe3f0b..92b2a4948d3 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -10,7 +10,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StrictData #-} @@ -35,7 +34,7 @@ import Data.Array import Data.Kind qualified as GHC import Data.Proxy import Data.Some.GADT -import GHC.Exts (inline, oneShot) +import GHC.Exts (inline, lazy, oneShot) import GHC.TypeLits -- | Turn a list of Haskell types @args@ into a functional type ending in @res@. @@ -64,7 +63,7 @@ data BuiltinMeaning val cost = forall args res. BuiltinMeaning (TypeScheme val args res) ~(FoldArgs args res) - (cost -> (# BuiltinRuntime val #)) + (cost -> BuiltinRuntime val) -- | Constraints available when defining a built-in function. type HasMeaningIn uni val = (Typeable val, ExMemoryUsage val, HasConstantIn uni val) @@ -380,13 +379,13 @@ instance -- Those thunks however require a lot of care to be properly shared rather than -- recreated every time a builtin application is evaluated, see 'toBuiltinsRuntime' for -- how we sort it out. - (# case toExF cost of + lazy $ case toExF cost of -- See Note [Optimizations of runCostingFun*] for why we use strict @case@. - !exF -> toPolyF @binds @val @args @res $ pure (f, exF) #) + !exF -> toPolyF @binds @val @args @res $ pure (f, exF) {-# INLINE makeBuiltinMeaning #-} -- | Convert a 'BuiltinMeaning' to a 'BuiltinRuntime' given a cost model. -toBuiltinRuntime :: cost -> BuiltinMeaning val cost -> (# BuiltinRuntime val #) +toBuiltinRuntime :: cost -> BuiltinMeaning val cost -> BuiltinRuntime val toBuiltinRuntime cost (BuiltinMeaning _ _ denot) = denot cost {-# INLINE toBuiltinRuntime #-} @@ -399,8 +398,7 @@ toBuiltinsRuntime -> cost -> BuiltinsRuntime fun val toBuiltinsRuntime semvar cost = - let runtime = BuiltinsRuntime $ \fun -> - toBuiltinRuntime cost $ inline toBuiltinMeaning semvar fun + 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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs index 872053356fd..a77378a4218 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE StrictData #-} module PlutusCore.Builtin.Runtime where @@ -12,7 +10,6 @@ import PlutusCore.Builtin.KnownType import PlutusCore.Evaluation.Machine.ExBudgetStream import Control.DeepSeq -import GHC.Magic (noinline) import NoThunks.Class -- | A 'BuiltinRuntime' represents a possibly partial builtin application, including an empty @@ -67,23 +64,21 @@ instance NFData (BuiltinRuntime val) where -- In order for lookups to be efficient the 'BuiltinRuntime's need to be cached, i.e. pulled out -- of the function statically. See 'makeBuiltinMeaning' for how we achieve that. data BuiltinsRuntime fun val = BuiltinsRuntime - { unBuiltinsRuntime :: fun -> (# BuiltinRuntime val #) + { unBuiltinsRuntime :: fun -> BuiltinRuntime val } instance (Bounded fun, Enum fun) => NFData (BuiltinsRuntime fun val) where -- Force every 'BuiltinRuntime' stored in the environment. - rnf (BuiltinsRuntime env) = - foldr (\fun res -> case noinline env fun of (# runtime #) -> runtime `seq` res) () enumerate + rnf (BuiltinsRuntime env) = foldr (\fun res -> env fun `seq` res) () enumerate instance (Bounded fun, Enum fun) => NoThunks (BuiltinsRuntime fun val) where -- Ensure that every 'BuiltinRuntime' doesn't contain thunks after forcing it initially -- (we can't avoid the initial forcing, because we can't lookup the 'BuiltinRuntime' without -- forcing it, see https://stackoverflow.com/q/63441862). - wNoThunks ctx (BuiltinsRuntime env) = - allNoThunks $ map (\fun -> case env fun of (# runtime #) -> noThunks ctx runtime) enumerate + wNoThunks ctx (BuiltinsRuntime env) = allNoThunks $ map (wNoThunks ctx . env) enumerate showTypeOf = const "PlutusCore.Builtin.Runtime.BuiltinsRuntime" -- | Look up the runtime info of a built-in function during evaluation. lookupBuiltin :: fun -> BuiltinsRuntime fun val -> BuiltinRuntime val -lookupBuiltin fun (BuiltinsRuntime env) = case env fun of (# runtime #) -> runtime +lookupBuiltin fun (BuiltinsRuntime env) = env fun {-# INLINE lookupBuiltin #-} diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs index 17879141bce..01a0c4021ce 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/EvaluateBuiltins.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-} -- | A pass that tries to evaluate builtin applications in the program. -- @@ -80,8 +79,7 @@ evaluateBuiltins conservative binfo costModel = transformOf termSubterms process processTerm :: Term tyname name uni fun a -> Term tyname name uni fun a -- See Note [Context splitting in a recursive pass] processTerm t@(splitApplication -> (Builtin x bn, argCtx)) = - let (# runtime #) = - toBuiltinRuntime costModel (toBuiltinMeaning (binfo ^. biSemanticsVariant) bn) + let runtime = toBuiltinRuntime costModel (toBuiltinMeaning (binfo ^. biSemanticsVariant) bn) in case eval runtime argCtx of -- Builtin evaluation gives us a fresh term with no annotation. -- Use the annotation of the builtin node, arbitrarily. This is slightly From 1705f9ed48df41e691d7210dd52d6962bf6c361b Mon Sep 17 00:00:00 2001 From: effectfully Date: Wed, 28 Feb 2024 15:44:45 +0100 Subject: [PATCH 04/29] Fix validation benchmarks --- plutus-benchmark/validation/bench/Common.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plutus-benchmark/validation/bench/Common.hs b/plutus-benchmark/validation/bench/Common.hs index 7ba3025f37a..5f1c2691015 100644 --- a/plutus-benchmark/validation/bench/Common.hs +++ b/plutus-benchmark/validation/bench/Common.hs @@ -139,7 +139,7 @@ mkEvalCtx :: EvaluationContext mkEvalCtx = case PLC.defaultCostModelParams of -- The validation benchmarks were all created from PlutusV1 scripts - Just p -> case mkDynEvaluationContext PLC.DefaultFunSemanticsVariant1 p of + Just p -> case mkDynEvaluationContext (const PLC.DefaultFunSemanticsVariant1) p of Right ec -> ec Left err -> error $ show err Nothing -> error "Couldn't get cost model params" From 32c08f0295bc3778bfb423e3a278718e196e7486 Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 29 Feb 2024 22:34:21 +0100 Subject: [PATCH 05/29] Fix a bunch more stuff --- plutus-conformance/haskell/Spec.hs | 4 ++-- .../test/Evaluation/Builtins/SignatureVerification.hs | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index dff190546b6..b8ec55b58af 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/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 (const def) modelParams of Left _ -> Nothing - Right p -> Just p + Right p -> Just $ 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 diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs index 5715b3f94d8..e2df76b66e3 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs +++ b/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, From 3f960211f6083b7474de8fc7f0ed60dfbc4f0c95 Mon Sep 17 00:00:00 2001 From: effectfully Date: Sat, 16 Mar 2024 00:02:39 +0100 Subject: [PATCH 06/29] Cosmetics --- .../plutus-core/src/PlutusCore/Default/Builtins.hs | 10 +++++----- .../test/Evaluation/Builtins/Definition.hs | 4 +++- .../test/Evaluation/Builtins/SignatureVerification.hs | 4 ++-- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index f7d0d36d702..8b1c1bac8f9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1187,7 +1187,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where :: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream costingFun = runCostingFunTwoArguments . paramConsByteString {-# INLINE costingFun #-} - consByteStringMeaningV1 = + consByteStringMeaning_V1 = let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString consByteStringDenotation n xs = BS.cons (fromIntegral n) xs {-# INLINE consByteStringDenotation #-} @@ -1196,7 +1196,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where costingFun -- For builtin semantics variants larger than 'DefaultFunSemanticsVariant1', the first -- input must be in range @[0..255]@. - consByteStringMeaningV2 = + consByteStringMeaning_V2 = let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString consByteStringDenotation = BS.cons {-# INLINE consByteStringDenotation #-} @@ -1204,9 +1204,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where consByteStringDenotation costingFun in case semvar of - DefaultFunSemanticsVariant0 -> consByteStringMeaningV1 - DefaultFunSemanticsVariant1 -> consByteStringMeaningV1 - DefaultFunSemanticsVariant2 -> consByteStringMeaningV2 + DefaultFunSemanticsVariant0 -> consByteStringMeaning_V1 + DefaultFunSemanticsVariant1 -> consByteStringMeaning_V1 + DefaultFunSemanticsVariant2 -> consByteStringMeaning_V2 toBuiltinMeaning _semvar SliceByteString = let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index c4f6018d2e9..c7d6eb915e8 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -772,7 +772,9 @@ test_ConsByteString = 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 + typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant0 def) defaultBuiltinCostModelExt expr1 + Right (EvaluationSuccess $ cons @ByteString "!hello world") @=? + typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant1 def) defaultBuiltinCostModelExt expr1 Right EvaluationFailure @=? typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant2 def) defaultBuiltinCostModelExt expr1 Right EvaluationFailure @=? diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs index e2df76b66e3..3bd113cb378 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/SignatureVerification.hs @@ -77,10 +77,10 @@ ed25519Prop semvar = do runTestDataWith semvar testCase id VerifyEd25519Signature ed25519_Variant0Prop :: PropertyT IO () -ed25519_Variant0Prop = ed25519Prop (DefaultFunSemanticsVariant0) +ed25519_Variant0Prop = ed25519Prop DefaultFunSemanticsVariant0 ed25519_Variant1Prop :: PropertyT IO () -ed25519_Variant1Prop = ed25519Prop (DefaultFunSemanticsVariant1) +ed25519_Variant1Prop = ed25519Prop DefaultFunSemanticsVariant1 ed25519_Variant2Prop :: PropertyT IO () ed25519_Variant2Prop = ed25519Prop DefaultFunSemanticsVariant2 From 430d7f9d19088a77bbc5c520223ae84237db0690 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 19 Mar 2024 04:01:33 +0100 Subject: [PATCH 07/29] Remove warnings --- plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs | 6 +----- plutus-core/testlib/PlutusIR/Pass/Test.hs | 2 -- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index b9802a257ac..c103b7922c6 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -411,9 +411,5 @@ toBuiltinsRuntime semvar cost = -- 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. - runtime + in runtime {-# INLINE toBuiltinsRuntime #-} diff --git a/plutus-core/testlib/PlutusIR/Pass/Test.hs b/plutus-core/testlib/PlutusIR/Pass/Test.hs index 311f018e22e..34a8b070248 100644 --- a/plutus-core/testlib/PlutusIR/Pass/Test.hs +++ b/plutus-core/testlib/PlutusIR/Pass/Test.hs @@ -5,8 +5,6 @@ module PlutusIR.Pass.Test where import Control.Monad.Except -import Data.Bifunctor (first) -import Data.Functor (void) import Data.Typeable import PlutusCore qualified as PLC import PlutusCore.Builtin From aef3def26e0e6e3c4c61ae07844008e21783a6d7 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 19 Mar 2024 12:30:16 +0100 Subject: [PATCH 08/29] Push 'MajorProtocolVersion' into 'MachineParameters' --- plutus-conformance/haskell/Spec.hs | 2 +- .../budgeting-bench/Benchmarks/Nops.hs | 3 +- .../cost-model/budgeting-bench/Common.hs | 2 +- .../src/PlutusCore/Builtin/Meaning.hs | 15 +------- .../Evaluation/Machine/ExBudgetingDefaults.hs | 7 ++-- .../Evaluation/Machine/MachineParameters.hs | 35 +++++++++++-------- .../Machine/MachineParameters/Default.hs | 10 +++--- .../Evaluation/Machine/Cek.hs | 19 +++++----- .../Evaluation/Machine/Cek/Internal.hs | 4 +-- .../Evaluation/Machine/CommonAPI.hs | 18 +++++----- .../Evaluation/Machine/SteppableCek.hs | 16 ++++----- .../Machine/SteppableCek/Internal.hs | 4 +-- .../test/Evaluation/Builtins/Common.hs | 2 +- .../src/PlutusLedgerApi/Common/Eval.hs | 12 +++++-- 14 files changed, 77 insertions(+), 72 deletions(-) diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index b8ec55b58af..9c8d8156ad5 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/plutus-conformance/haskell/Spec.hs @@ -14,7 +14,7 @@ evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do params <- case mkMachineParametersFor (const def) modelParams of Left _ -> Nothing - Right p -> Just $ p () + Right p -> Just $ ($ ()) <$> 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 diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs index feeaa4cf3b6..295eb1106b8 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs @@ -120,7 +120,8 @@ nopCostModel = (ModelSixArgumentsConstantCost 600) } -nopCostParameters :: MachineParameters CekMachineCosts NopFun (CekValue DefaultUni NopFun ()) +nopCostParameters :: + MachineParameters CekMachineCosts (BuiltinsRuntime NopFun (CekValue DefaultUni NopFun ())) nopCostParameters = mkMachineParameters def $ CostModel defaultCekMachineCosts nopCostModel diff --git a/plutus-core/cost-model/budgeting-bench/Common.hs b/plutus-core/cost-model/budgeting-bench/Common.hs index a314102ffda..9d261c83c6e 100644 --- a/plutus-core/cost-model/budgeting-bench/Common.hs +++ b/plutus-core/cost-model/budgeting-bench/Common.hs @@ -74,7 +74,7 @@ copyData = benchWith :: (Pretty fun, Typeable fun) - => MachineParameters CekMachineCosts fun (CekValue DefaultUni fun ()) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue DefaultUni fun ())) -> String -> PlainTerm DefaultUni fun -> Benchmark diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index c103b7922c6..e84ef9cbec9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -398,18 +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 runtime + BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar {-# INLINE toBuiltinsRuntime #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 3376f84cafb..9a2843e7412 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -84,8 +84,9 @@ defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel defaultCostModelParams :: Maybe CostModelParams defaultCostModelParams = extractCostModelParams defaultCekCostModel -defaultCekParameters :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) -defaultCekParameters = mkMachineParameters def defaultCekCostModel +defaultCekParameters :: Typeable ann => MachineParameters CekMachineCosts (BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ann)) +-- See Note [noinline for saving on ticks]. +defaultCekParameters = noinline mkMachineParameters def defaultCekCostModel {- Note [noinline for saving on ticks] We use 'noinline' purely for saving on simplifier ticks for definitions, whose performance doesn't @@ -93,7 +94,7 @@ matter. Otherwise compilation for this module is slower and GHC may end up exhau ticks leading to a compilation error. -} -unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) +unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts (BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ann)) unitCekParameters = -- See Note [noinline for saving on ticks]. noinline mkMachineParameters def $ diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index f830cf1a24a..f2f86687fce 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -14,6 +14,7 @@ import Control.DeepSeq import Control.Lens import GHC.Exts (inline) import GHC.Generics +import GHC.Magic (noinline) import NoThunks.Class {-| We need to account for the costs of evaluator steps and also built-in function @@ -36,18 +37,13 @@ makeLenses ''CostModel cost model for builtins and their denotations. This bundles one of those together with the cost model for evaluator steps. The 'term' type will be CekValue when we're using this with the CEK machine. -} -data MachineParameters machinecosts fun val = +data MachineParameters machinecosts builtinsRuntime = MachineParameters { machineCosts :: machinecosts - , builtinsRuntime :: BuiltinsRuntime fun val + , builtinsRuntime :: builtinsRuntime } - 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 ] + deriving stock (Generic, Functor, Foldable, Traversable) + deriving anyclass (NFData, NoThunks) {- Note [The CostingPart constraint in mkMachineParameters] Discharging the @CostingPart uni fun ~ builtincosts@ constraint in 'mkMachineParameters' causes GHC @@ -76,16 +72,27 @@ which makes sense: if @f@ receives all its type and term args then there's less -- See Note [Inlining meanings of builtins]. {-| This just uses 'toBuiltinsRuntime' function to convert a BuiltinCostModel to a BuiltinsRuntime. -} -mkMachineParameters :: +mkMachineParametersFun :: ( -- WARNING: do not discharge the equality constraint as that causes GHC to fail to inline the -- function at its call site, see Note [The CostingPart constraint in mkMachineParameters]. CostingPart uni fun ~ builtincosts , HasMeaningIn uni val , ToBuiltinMeaning uni fun ) - => BuiltinSemanticsVariant fun + => (a -> BuiltinSemanticsVariant fun) -> CostModel machinecosts builtincosts - -> MachineParameters machinecosts fun val -mkMachineParameters semvar (CostModel mchnCosts builtinCosts) = - MachineParameters mchnCosts (inline toBuiltinsRuntime semvar builtinCosts) + -> MachineParameters machinecosts (a -> BuiltinsRuntime fun val) +mkMachineParametersFun toSemVar (CostModel mchnCosts builtinCosts) = + MachineParameters mchnCosts $ \x -> inline toBuiltinsRuntime (toSemVar x) builtinCosts {-# INLINE mkMachineParameters #-} + +mkMachineParameters :: + ( CostingPart uni fun ~ builtincosts + , HasMeaningIn uni val + , ToBuiltinMeaning uni fun + ) + => BuiltinSemanticsVariant fun + -> CostModel machinecosts builtincosts + -> MachineParameters machinecosts (BuiltinsRuntime fun val) +-- See Note [noinline for saving on ticks]. +mkMachineParameters semVar = fmap ($ ()) . noinline mkMachineParametersFun (const semVar) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index e86e12f679b..119e08a1f87 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -16,8 +16,10 @@ import GHC.Exts (inline) -- | 'MachineParameters' instantiated at CEK-machine-specific types and default builtins. -- Encompasses everything we need for evaluating a UPLC program with default builtins using the CEK -- machine. -type DefaultMachineParameters = - MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) +type DefaultMachineParameters a = + MachineParameters + CekMachineCosts + (a -> BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ())) {- Note [Inlining meanings of builtins] It's vitally important to inline the 'toBuiltinMeaning' method of a set of built-in functions as @@ -59,9 +61,9 @@ mkMachineParametersFor :: MonadError CostModelApplyError m => (a -> BuiltinSemanticsVariant DefaultFun) -> CostModelParams - -> m (a -> DefaultMachineParameters) + -> m (DefaultMachineParameters a) mkMachineParametersFor toSemVar newCMP = - (\cost x -> inline mkMachineParameters (toSemVar x) cost) <$> + inline mkMachineParametersFun toSemVar <$> applyCostModelParams defaultCekCostModel newCMP -- 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 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs index 7a7639fcbb8..221b0d00aa5 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs +++ b/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 @@ -70,7 +71,7 @@ A wrapper around the internal runCek to debruijn input and undebruijn output. -} runCek :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Term Name uni fun ann @@ -81,7 +82,7 @@ runCek = Common.runCek runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) @@ -93,7 +94,7 @@ May throw a 'CekMachineException'. -} unsafeRunCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), cost) @@ -104,7 +105,7 @@ unsafeRunCekNoEmit = Common.unsafeRunCekNoEmit runCekDeBruijn evaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek = Common.evaluateCek runCekDeBruijn @@ -113,7 +114,7 @@ evaluateCek = Common.evaluateCek runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* evaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit = Common.evaluateCekNoEmit runCekDeBruijn @@ -123,7 +124,7 @@ evaluateCekNoEmit = Common.evaluateCekNoEmit runCekDeBruijn unsafeEvaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), [Text]) unsafeEvaluateCek = Common.unsafeEvaluateCek runCekDeBruijn @@ -132,7 +133,7 @@ unsafeEvaluateCek = Common.unsafeEvaluateCek runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* unsafeEvaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> EvaluationResult (Term Name uni fun ()) unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit runCekDeBruijn @@ -141,7 +142,7 @@ unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* readKnownCek :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) a readKnownCek = Common.readKnownCek runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index d310786a018..22d7bca83fe 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -599,7 +599,7 @@ transferArgStack (ConsStack arg rest) c = transferArgStack rest (FrameAwaitFunVa runCekM :: forall a cost uni fun ann . ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> (forall s. GivenCekReqs uni fun ann s => CekM uni fun s a) @@ -868,7 +868,7 @@ enterComputeCek = computeCek -- | Evaluate a term using the CEK machine and keep track of costing, logging is optional. runCekDeBruijn :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> NTerm uni fun ann diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs index fa24c961b5c..3415380ae4b 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs @@ -75,7 +75,7 @@ import Data.Text (Text) -- The type of the machine (runner function). type MachineRunner cost uni fun ann = - MachineParameters CekMachineCosts fun (CekValue uni fun ann) + MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> NTerm uni fun ann @@ -98,7 +98,7 @@ A wrapper around the internal runCek to debruijn input and undebruijn output. -} runCek :: MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Term Name uni fun ann @@ -129,7 +129,7 @@ runCek runner params mode emitMode term = -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit :: MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) @@ -144,7 +144,7 @@ May throw a 'CekMachineException'. unsafeRunCekNoEmit :: ThrowableBuiltins uni fun => MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), cost) @@ -158,7 +158,7 @@ evaluateCek :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann -> EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek runner emitMode params = @@ -170,7 +170,7 @@ evaluateCek runner emitMode params = evaluateCekNoEmit :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit runner params = fst . runCekNoEmit runner params restrictingEnormous @@ -181,7 +181,7 @@ unsafeEvaluateCek :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann -> EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), [Text]) unsafeEvaluateCek runner emitTime params = @@ -193,7 +193,7 @@ unsafeEvaluateCek runner emitTime params = unsafeEvaluateCekNoEmit :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> EvaluationResult (Term Name uni fun ()) unsafeEvaluateCekNoEmit runner params = unsafeExtractEvaluationResult . evaluateCekNoEmit runner params @@ -203,7 +203,7 @@ unsafeEvaluateCekNoEmit runner params = unsafeExtractEvaluationResult . evaluate readKnownCek :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) a readKnownCek runner params = evaluateCekNoEmit runner params >=> readKnownSelf diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs index e81bf9ac973..a7d9aabe14a 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs @@ -69,7 +69,7 @@ A wrapper around the internal runCek to debruijn input and undebruijn output. -} runCek :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Term Name uni fun ann @@ -81,7 +81,7 @@ runCek = Common.runCek S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) @@ -94,7 +94,7 @@ May throw a 'CekMachineException'. -} unsafeRunCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), cost) @@ -105,7 +105,7 @@ unsafeRunCekNoEmit = Common.unsafeRunCekNoEmit S.runCekDeBruijn evaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek = Common.evaluateCek S.runCekDeBruijn @@ -114,7 +114,7 @@ evaluateCek = Common.evaluateCek S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* evaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit = Common.evaluateCekNoEmit S.runCekDeBruijn @@ -125,7 +125,7 @@ evaluateCekNoEmit = Common.evaluateCekNoEmit S.runCekDeBruijn unsafeEvaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) + -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), [Text]) unsafeEvaluateCek = Common.unsafeEvaluateCek S.runCekDeBruijn @@ -135,7 +135,7 @@ unsafeEvaluateCek = Common.unsafeEvaluateCek S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* unsafeEvaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> EvaluationResult (Term Name uni fun ()) unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit S.runCekDeBruijn @@ -144,7 +144,7 @@ unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* readKnownCek :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) a readKnownCek = Common.readKnownCek S.runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 5cf72765816..f2b076008a4 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -270,7 +270,7 @@ applyEvaluate !_ val _ = -- MAYBE: runCekDeBruijn can be shared between original&debug ceks by passing a `enterComputeCek` func. runCekDeBruijn :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> NTerm uni fun ann @@ -327,7 +327,7 @@ mkCekTrans :: forall cost uni fun ann m s . ( ThrowableBuiltins uni fun , PrimMonad m, s ~ PrimState m) -- the outer monad that initializes the transition function - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) + => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Slippage diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs index 285059ed8f2..d9fe24f8487 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs @@ -35,7 +35,7 @@ typecheckAnd , Closed uni, uni `Everywhere` ExMemoryUsage ) => BuiltinSemanticsVariant fun - -> (MachineParameters CekMachineCosts fun (CekValue uni fun ()) -> + -> (MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ())) -> UPLC.Term Name uni fun () -> a) -> CostingPart uni fun -> TPLC.Term TyName Name uni fun () -> m a typecheckAnd semvar action costingPart term = TPLC.runQuoteT $ do diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 3e710e759af..fed2012fa00 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -27,6 +27,7 @@ import PlutusCore.Default import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus import PlutusCore.Evaluation.Machine.ExBudget as Plutus import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as Plutus +import PlutusCore.Evaluation.Machine.MachineParameters (MachineParameters) import PlutusCore.Evaluation.Machine.MachineParameters.Default import PlutusCore.MkPlc qualified as UPLC import PlutusCore.Pretty @@ -105,15 +106,20 @@ mkTermToEvaluate ll pv script args = do -- make sure that term is closed, i.e. well-scoped through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT -toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters -toMachineParameters pv ctx = machineParameters ctx pv +toMachineParameters + :: MajorProtocolVersion + -> EvaluationContext + -> MachineParameters + CekMachineCosts + (UPLC.BuiltinsRuntime DefaultFun (UPLC.CekValue DefaultUni DefaultFun ())) +toMachineParameters pv ctx = ($ pv) <$> machineParameters ctx {-| 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 :: MajorProtocolVersion -> DefaultMachineParameters + { machineParameters :: DefaultMachineParameters MajorProtocolVersion } deriving stock Generic deriving anyclass (NFData, NoThunks) From 21bb075a0308786107d50c32885d77e8bc25fe8b Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 8 Mar 2024 01:53:13 +0100 Subject: [PATCH 09/29] Make 'CostingPart' into a function --- .../src/PlutusCore/Default/Builtins.hs | 305 +++++++++--------- .../Evaluation/Machine/ExBudgetingDefaults.hs | 13 +- .../Evaluation/Machine/MachineParameters.hs | 2 +- 3 files changed, 162 insertions(+), 158 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 8b1c1bac8f9..0c735634b14 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1069,7 +1069,7 @@ do it quite yet, even though it worked (the Plutus Tx part wasn't implemented). -} instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where - type CostingPart uni DefaultFun = BuiltinCostModel + type CostingPart uni DefaultFun = BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel {- | Allow different variants of builtins with different implementations, and possibly different semantics. Note that DefaultFunSemanticsVariant1, @@ -1086,96 +1086,96 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where :: forall val. HasMeaningIn uni val => BuiltinSemanticsVariant DefaultFun -> DefaultFun - -> BuiltinMeaning val BuiltinCostModel + -> BuiltinMeaning val (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) - toBuiltinMeaning _semvar AddInteger = + toBuiltinMeaning semvar AddInteger = let addIntegerDenotation :: Integer -> Integer -> Integer addIntegerDenotation = (+) {-# INLINE addIntegerDenotation #-} in makeBuiltinMeaning addIntegerDenotation - (runCostingFunTwoArguments . paramAddInteger) + (runCostingFunTwoArguments . paramAddInteger . ($ semvar)) - toBuiltinMeaning _semvar SubtractInteger = + toBuiltinMeaning semvar SubtractInteger = let subtractIntegerDenotation :: Integer -> Integer -> Integer subtractIntegerDenotation = (-) {-# INLINE subtractIntegerDenotation #-} in makeBuiltinMeaning subtractIntegerDenotation - (runCostingFunTwoArguments . paramSubtractInteger) + (runCostingFunTwoArguments . paramSubtractInteger . ($ semvar)) - toBuiltinMeaning _semvar MultiplyInteger = + toBuiltinMeaning semvar MultiplyInteger = let multiplyIntegerDenotation :: Integer -> Integer -> Integer multiplyIntegerDenotation = (*) {-# INLINE multiplyIntegerDenotation #-} in makeBuiltinMeaning multiplyIntegerDenotation - (runCostingFunTwoArguments . paramMultiplyInteger) + (runCostingFunTwoArguments . paramMultiplyInteger . ($ semvar)) - toBuiltinMeaning _semvar DivideInteger = + toBuiltinMeaning semvar DivideInteger = let divideIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer divideIntegerDenotation = nonZeroSecondArg div {-# INLINE divideIntegerDenotation #-} in makeBuiltinMeaning divideIntegerDenotation - (runCostingFunTwoArguments . paramDivideInteger) + (runCostingFunTwoArguments . paramDivideInteger . ($ semvar)) - toBuiltinMeaning _semvar QuotientInteger = + toBuiltinMeaning semvar QuotientInteger = let quotientIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer quotientIntegerDenotation = nonZeroSecondArg quot {-# INLINE quotientIntegerDenotation #-} in makeBuiltinMeaning quotientIntegerDenotation - (runCostingFunTwoArguments . paramQuotientInteger) + (runCostingFunTwoArguments . paramQuotientInteger . ($ semvar)) - toBuiltinMeaning _semvar RemainderInteger = + toBuiltinMeaning semvar RemainderInteger = let remainderIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer remainderIntegerDenotation = nonZeroSecondArg rem {-# INLINE remainderIntegerDenotation #-} in makeBuiltinMeaning remainderIntegerDenotation - (runCostingFunTwoArguments . paramRemainderInteger) + (runCostingFunTwoArguments . paramRemainderInteger . ($ semvar)) - toBuiltinMeaning _semvar ModInteger = + toBuiltinMeaning semvar ModInteger = let modIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer modIntegerDenotation = nonZeroSecondArg mod {-# INLINE modIntegerDenotation #-} in makeBuiltinMeaning modIntegerDenotation - (runCostingFunTwoArguments . paramModInteger) + (runCostingFunTwoArguments . paramModInteger . ($ semvar)) - toBuiltinMeaning _semvar EqualsInteger = + toBuiltinMeaning semvar EqualsInteger = let equalsIntegerDenotation :: Integer -> Integer -> Bool equalsIntegerDenotation = (==) {-# INLINE equalsIntegerDenotation #-} in makeBuiltinMeaning equalsIntegerDenotation - (runCostingFunTwoArguments . paramEqualsInteger) + (runCostingFunTwoArguments . paramEqualsInteger . ($ semvar)) - toBuiltinMeaning _semvar LessThanInteger = + toBuiltinMeaning semvar LessThanInteger = let lessThanIntegerDenotation :: Integer -> Integer -> Bool lessThanIntegerDenotation = (<) {-# INLINE lessThanIntegerDenotation #-} in makeBuiltinMeaning lessThanIntegerDenotation - (runCostingFunTwoArguments . paramLessThanInteger) + (runCostingFunTwoArguments . paramLessThanInteger . ($ semvar)) - toBuiltinMeaning _semvar LessThanEqualsInteger = + toBuiltinMeaning semvar LessThanEqualsInteger = let lessThanEqualsIntegerDenotation :: Integer -> Integer -> Bool lessThanEqualsIntegerDenotation = (<=) {-# INLINE lessThanEqualsIntegerDenotation #-} in makeBuiltinMeaning lessThanEqualsIntegerDenotation - (runCostingFunTwoArguments . paramLessThanEqualsInteger) + (runCostingFunTwoArguments . paramLessThanEqualsInteger . ($ semvar)) -- Bytestrings - toBuiltinMeaning _semvar AppendByteString = + toBuiltinMeaning semvar AppendByteString = let appendByteStringDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString appendByteStringDenotation = BS.append {-# INLINE appendByteStringDenotation #-} in makeBuiltinMeaning appendByteStringDenotation - (runCostingFunTwoArguments . paramAppendByteString) + (runCostingFunTwoArguments . paramAppendByteString . ($ semvar)) -- See Note [Builtin semantics variants] toBuiltinMeaning semvar ConsByteString = @@ -1184,8 +1184,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- different types ('Integer' vs 'Word8'), the costing function needs to -- by polymorphic over the type of constant. let costingFun - :: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream - costingFun = runCostingFunTwoArguments . paramConsByteString + :: ExMemoryUsage a + => (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) + -> a -> BS.ByteString -> ExBudgetStream + costingFun = runCostingFunTwoArguments . paramConsByteString . ($ semvar) {-# INLINE costingFun #-} consByteStringMeaning_V1 = let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString @@ -1208,23 +1210,23 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where DefaultFunSemanticsVariant1 -> consByteStringMeaning_V1 DefaultFunSemanticsVariant2 -> consByteStringMeaning_V2 - toBuiltinMeaning _semvar SliceByteString = + toBuiltinMeaning semvar SliceByteString = let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString sliceByteStringDenotation start n xs = BS.take n (BS.drop start xs) {-# INLINE sliceByteStringDenotation #-} in makeBuiltinMeaning sliceByteStringDenotation - (runCostingFunThreeArguments . paramSliceByteString) + (runCostingFunThreeArguments . paramSliceByteString . ($ semvar)) - toBuiltinMeaning _semvar LengthOfByteString = + toBuiltinMeaning semvar LengthOfByteString = let lengthOfByteStringDenotation :: BS.ByteString -> Int lengthOfByteStringDenotation = BS.length {-# INLINE lengthOfByteStringDenotation #-} in makeBuiltinMeaning lengthOfByteStringDenotation - (runCostingFunOneArgument . paramLengthOfByteString) + (runCostingFunOneArgument . paramLengthOfByteString . ($ semvar)) - toBuiltinMeaning _semvar IndexByteString = + toBuiltinMeaning semvar IndexByteString = let indexByteStringDenotation :: BS.ByteString -> Int -> EvaluationResult Word8 indexByteStringDenotation xs n = do -- TODO: fix this mess with @indexMaybe@ from @bytestring >= 0.11.0.0@. @@ -1233,56 +1235,56 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE indexByteStringDenotation #-} in makeBuiltinMeaning indexByteStringDenotation - (runCostingFunTwoArguments . paramIndexByteString) + (runCostingFunTwoArguments . paramIndexByteString . ($ semvar)) - toBuiltinMeaning _semvar EqualsByteString = + toBuiltinMeaning semvar EqualsByteString = let equalsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool equalsByteStringDenotation = (==) {-# INLINE equalsByteStringDenotation #-} in makeBuiltinMeaning equalsByteStringDenotation - (runCostingFunTwoArguments . paramEqualsByteString) + (runCostingFunTwoArguments . paramEqualsByteString . ($ semvar)) - toBuiltinMeaning _semvar LessThanByteString = + toBuiltinMeaning semvar LessThanByteString = let lessThanByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool lessThanByteStringDenotation = (<) {-# INLINE lessThanByteStringDenotation #-} in makeBuiltinMeaning lessThanByteStringDenotation - (runCostingFunTwoArguments . paramLessThanByteString) + (runCostingFunTwoArguments . paramLessThanByteString . ($ semvar)) - toBuiltinMeaning _semvar LessThanEqualsByteString = + toBuiltinMeaning semvar LessThanEqualsByteString = let lessThanEqualsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool lessThanEqualsByteStringDenotation = (<=) {-# INLINE lessThanEqualsByteStringDenotation #-} in makeBuiltinMeaning lessThanEqualsByteStringDenotation - (runCostingFunTwoArguments . paramLessThanEqualsByteString) + (runCostingFunTwoArguments . paramLessThanEqualsByteString . ($ semvar)) -- Cryptography and hashes - toBuiltinMeaning _semvar Sha2_256 = + toBuiltinMeaning semvar Sha2_256 = let sha2_256Denotation :: BS.ByteString -> BS.ByteString sha2_256Denotation = Hash.sha2_256 {-# INLINE sha2_256Denotation #-} in makeBuiltinMeaning sha2_256Denotation - (runCostingFunOneArgument . paramSha2_256) + (runCostingFunOneArgument . paramSha2_256 . ($ semvar)) - toBuiltinMeaning _semvar Sha3_256 = + toBuiltinMeaning semvar Sha3_256 = let sha3_256Denotation :: BS.ByteString -> BS.ByteString sha3_256Denotation = Hash.sha3_256 {-# INLINE sha3_256Denotation #-} in makeBuiltinMeaning sha3_256Denotation - (runCostingFunOneArgument . paramSha3_256) + (runCostingFunOneArgument . paramSha3_256 . ($ semvar)) - toBuiltinMeaning _semvar Blake2b_256 = + toBuiltinMeaning semvar Blake2b_256 = let blake2b_256Denotation :: BS.ByteString -> BS.ByteString blake2b_256Denotation = Hash.blake2b_256 {-# INLINE blake2b_256Denotation #-} in makeBuiltinMeaning blake2b_256Denotation - (runCostingFunOneArgument . paramBlake2b_256) + (runCostingFunOneArgument . paramBlake2b_256 . ($ semvar)) toBuiltinMeaning semvar VerifyEd25519Signature = let verifyEd25519SignatureDenotation @@ -1298,7 +1300,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- Benchmarks indicate that the two variants have very similar -- execution times, so it's safe to use the same costing function for -- both. - (runCostingFunThreeArguments . paramVerifyEd25519Signature) + (runCostingFunThreeArguments . paramVerifyEd25519Signature . ($ semvar)) {- Note [ECDSA secp256k1 signature verification]. An ECDSA signature consists of a pair of values (r,s), and for each value of r there are in @@ -1316,86 +1318,86 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where https://github.com/bitcoin-core/secp256k1. -} - toBuiltinMeaning _semvar VerifyEcdsaSecp256k1Signature = + toBuiltinMeaning semvar VerifyEcdsaSecp256k1Signature = let verifyEcdsaSecp256k1SignatureDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool verifyEcdsaSecp256k1SignatureDenotation = verifyEcdsaSecp256k1Signature {-# INLINE verifyEcdsaSecp256k1SignatureDenotation #-} in makeBuiltinMeaning verifyEcdsaSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature) + (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature . ($ semvar)) - toBuiltinMeaning _semvar VerifySchnorrSecp256k1Signature = + toBuiltinMeaning semvar VerifySchnorrSecp256k1Signature = let verifySchnorrSecp256k1SignatureDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool verifySchnorrSecp256k1SignatureDenotation = verifySchnorrSecp256k1Signature {-# INLINE verifySchnorrSecp256k1SignatureDenotation #-} in makeBuiltinMeaning verifySchnorrSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature) + (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature . ($ semvar)) -- Strings - toBuiltinMeaning _semvar AppendString = + toBuiltinMeaning semvar AppendString = let appendStringDenotation :: Text -> Text -> Text appendStringDenotation = (<>) {-# INLINE appendStringDenotation #-} in makeBuiltinMeaning appendStringDenotation - (runCostingFunTwoArguments . paramAppendString) + (runCostingFunTwoArguments . paramAppendString . ($ semvar)) - toBuiltinMeaning _semvar EqualsString = + toBuiltinMeaning semvar EqualsString = let equalsStringDenotation :: Text -> Text -> Bool equalsStringDenotation = (==) {-# INLINE equalsStringDenotation #-} in makeBuiltinMeaning equalsStringDenotation - (runCostingFunTwoArguments . paramEqualsString) + (runCostingFunTwoArguments . paramEqualsString . ($ semvar)) - toBuiltinMeaning _semvar EncodeUtf8 = + toBuiltinMeaning semvar EncodeUtf8 = let encodeUtf8Denotation :: Text -> BS.ByteString encodeUtf8Denotation = encodeUtf8 {-# INLINE encodeUtf8Denotation #-} in makeBuiltinMeaning encodeUtf8Denotation - (runCostingFunOneArgument . paramEncodeUtf8) + (runCostingFunOneArgument . paramEncodeUtf8 . ($ semvar)) - toBuiltinMeaning _semvar DecodeUtf8 = + toBuiltinMeaning semvar DecodeUtf8 = let decodeUtf8Denotation :: BS.ByteString -> EvaluationResult Text decodeUtf8Denotation = reoption . decodeUtf8' {-# INLINE decodeUtf8Denotation #-} in makeBuiltinMeaning decodeUtf8Denotation - (runCostingFunOneArgument . paramDecodeUtf8) + (runCostingFunOneArgument . paramDecodeUtf8 . ($ semvar)) -- Bool - toBuiltinMeaning _semvar IfThenElse = + toBuiltinMeaning semvar IfThenElse = let ifThenElseDenotation :: Bool -> a -> a -> a ifThenElseDenotation b x y = if b then x else y {-# INLINE ifThenElseDenotation #-} in makeBuiltinMeaning ifThenElseDenotation - (runCostingFunThreeArguments . paramIfThenElse) + (runCostingFunThreeArguments . paramIfThenElse . ($ semvar)) -- Unit - toBuiltinMeaning _semvar ChooseUnit = + toBuiltinMeaning semvar ChooseUnit = let chooseUnitDenotation :: () -> a -> a chooseUnitDenotation () x = x {-# INLINE chooseUnitDenotation #-} in makeBuiltinMeaning chooseUnitDenotation - (runCostingFunTwoArguments . paramChooseUnit) + (runCostingFunTwoArguments . paramChooseUnit . ($ semvar)) -- Tracing - toBuiltinMeaning _semvar Trace = + toBuiltinMeaning semvar Trace = let traceDenotation :: Text -> a -> Emitter a traceDenotation text a = a <$ emit text {-# INLINE traceDenotation #-} in makeBuiltinMeaning traceDenotation - (runCostingFunTwoArguments . paramTrace) + (runCostingFunTwoArguments . paramTrace . ($ semvar)) -- Pairs - toBuiltinMeaning _semvar FstPair = + toBuiltinMeaning semvar FstPair = let fstPairDenotation :: SomeConstant uni (a, b) -> EvaluationResult (Opaque val a) fstPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = do DefaultUniPair uniA _ <- pure uniPairAB @@ -1403,9 +1405,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE fstPairDenotation #-} in makeBuiltinMeaning fstPairDenotation - (runCostingFunOneArgument . paramFstPair) + (runCostingFunOneArgument . paramFstPair . ($ semvar)) - toBuiltinMeaning _semvar SndPair = + toBuiltinMeaning semvar SndPair = let sndPairDenotation :: SomeConstant uni (a, b) -> EvaluationResult (Opaque val b) sndPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = do DefaultUniPair _ uniB <- pure uniPairAB @@ -1413,10 +1415,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE sndPairDenotation #-} in makeBuiltinMeaning sndPairDenotation - (runCostingFunOneArgument . paramSndPair) + (runCostingFunOneArgument . paramSndPair . ($ semvar)) -- Lists - toBuiltinMeaning _semvar ChooseList = + toBuiltinMeaning semvar ChooseList = let chooseListDenotation :: SomeConstant uni [a] -> b -> b -> EvaluationResult b chooseListDenotation (SomeConstant (Some (ValueOf uniListA xs))) a b = do DefaultUniList _ <- pure uniListA @@ -1426,9 +1428,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE chooseListDenotation #-} in makeBuiltinMeaning chooseListDenotation - (runCostingFunThreeArguments . paramChooseList) + (runCostingFunThreeArguments . paramChooseList . ($ semvar)) - toBuiltinMeaning _semvar MkCons = + toBuiltinMeaning semvar MkCons = let mkConsDenotation :: SomeConstant uni a -> SomeConstant uni [a] -> EvaluationResult (Opaque val [a]) mkConsDenotation @@ -1446,9 +1448,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkConsDenotation #-} in makeBuiltinMeaning mkConsDenotation - (runCostingFunTwoArguments . paramMkCons) + (runCostingFunTwoArguments . paramMkCons . ($ semvar)) - toBuiltinMeaning _semvar HeadList = + toBuiltinMeaning semvar HeadList = let headListDenotation :: SomeConstant uni [a] -> EvaluationResult (Opaque val a) headListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList uniA <- pure uniListA @@ -1457,9 +1459,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE headListDenotation #-} in makeBuiltinMeaning headListDenotation - (runCostingFunOneArgument . paramHeadList) + (runCostingFunOneArgument . paramHeadList . ($ semvar)) - toBuiltinMeaning _semvar TailList = + toBuiltinMeaning semvar TailList = let tailListDenotation :: SomeConstant uni [a] -> EvaluationResult (Opaque val [a]) tailListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList _ <- pure uniListA @@ -1468,9 +1470,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE tailListDenotation #-} in makeBuiltinMeaning tailListDenotation - (runCostingFunOneArgument . paramTailList) + (runCostingFunOneArgument . paramTailList . ($ semvar)) - toBuiltinMeaning _semvar NullList = + toBuiltinMeaning semvar NullList = let nullListDenotation :: SomeConstant uni [a] -> EvaluationResult Bool nullListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList _ <- pure uniListA @@ -1478,10 +1480,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE nullListDenotation #-} in makeBuiltinMeaning nullListDenotation - (runCostingFunOneArgument . paramNullList) + (runCostingFunOneArgument . paramNullList . ($ semvar)) -- Data - toBuiltinMeaning _semvar ChooseData = + toBuiltinMeaning semvar ChooseData = let chooseDataDenotation :: Data -> a -> a -> a -> a -> a -> a chooseDataDenotation d xConstr xMap xList xI xB = case d of @@ -1493,49 +1495,49 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE chooseDataDenotation #-} in makeBuiltinMeaning chooseDataDenotation - (runCostingFunSixArguments . paramChooseData) + (runCostingFunSixArguments . paramChooseData . ($ semvar)) - toBuiltinMeaning _semvar ConstrData = + toBuiltinMeaning semvar ConstrData = let constrDataDenotation :: Integer -> [Data] -> Data constrDataDenotation = Constr {-# INLINE constrDataDenotation #-} in makeBuiltinMeaning constrDataDenotation - (runCostingFunTwoArguments . paramConstrData) + (runCostingFunTwoArguments . paramConstrData . ($ semvar)) - toBuiltinMeaning _semvar MapData = + toBuiltinMeaning semvar MapData = let mapDataDenotation :: [(Data, Data)] -> Data mapDataDenotation = Map {-# INLINE mapDataDenotation #-} in makeBuiltinMeaning mapDataDenotation - (runCostingFunOneArgument . paramMapData) + (runCostingFunOneArgument . paramMapData . ($ semvar)) - toBuiltinMeaning _semvar ListData = + toBuiltinMeaning semvar ListData = let listDataDenotation :: [Data] -> Data listDataDenotation = List {-# INLINE listDataDenotation #-} in makeBuiltinMeaning listDataDenotation - (runCostingFunOneArgument . paramListData) + (runCostingFunOneArgument . paramListData . ($ semvar)) - toBuiltinMeaning _semvar IData = + toBuiltinMeaning semvar IData = let iDataDenotation :: Integer -> Data iDataDenotation = I {-# INLINE iDataDenotation #-} in makeBuiltinMeaning iDataDenotation - (runCostingFunOneArgument . paramIData) + (runCostingFunOneArgument . paramIData . ($ semvar)) - toBuiltinMeaning _semvar BData = + toBuiltinMeaning semvar BData = let bDataDenotation :: BS.ByteString -> Data bDataDenotation = B {-# INLINE bDataDenotation #-} in makeBuiltinMeaning bDataDenotation - (runCostingFunOneArgument . paramBData) + (runCostingFunOneArgument . paramBData . ($ semvar)) - toBuiltinMeaning _semvar UnConstrData = + toBuiltinMeaning semvar UnConstrData = let unConstrDataDenotation :: Data -> EvaluationResult (Integer, [Data]) unConstrDataDenotation = \case Constr i ds -> EvaluationSuccess (i, ds) @@ -1543,9 +1545,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unConstrDataDenotation #-} in makeBuiltinMeaning unConstrDataDenotation - (runCostingFunOneArgument . paramUnConstrData) + (runCostingFunOneArgument . paramUnConstrData . ($ semvar)) - toBuiltinMeaning _semvar UnMapData = + toBuiltinMeaning semvar UnMapData = let unMapDataDenotation :: Data -> EvaluationResult [(Data, Data)] unMapDataDenotation = \case Map es -> EvaluationSuccess es @@ -1553,9 +1555,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unMapDataDenotation #-} in makeBuiltinMeaning unMapDataDenotation - (runCostingFunOneArgument . paramUnMapData) + (runCostingFunOneArgument . paramUnMapData . ($ semvar)) - toBuiltinMeaning _semvar UnListData = + toBuiltinMeaning semvar UnListData = let unListDataDenotation :: Data -> EvaluationResult [Data] unListDataDenotation = \case List ds -> EvaluationSuccess ds @@ -1563,9 +1565,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unListDataDenotation #-} in makeBuiltinMeaning unListDataDenotation - (runCostingFunOneArgument . paramUnListData) + (runCostingFunOneArgument . paramUnListData . ($ semvar)) - toBuiltinMeaning _semvar UnIData = + toBuiltinMeaning semvar UnIData = let unIDataDenotation :: Data -> EvaluationResult Integer unIDataDenotation = \case I i -> EvaluationSuccess i @@ -1573,9 +1575,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unIDataDenotation #-} in makeBuiltinMeaning unIDataDenotation - (runCostingFunOneArgument . paramUnIData) + (runCostingFunOneArgument . paramUnIData . ($ semvar)) - toBuiltinMeaning _semvar UnBData = + toBuiltinMeaning semvar UnBData = let unBDataDenotation :: Data -> EvaluationResult BS.ByteString unBDataDenotation = \case B b -> EvaluationSuccess b @@ -1583,34 +1585,34 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unBDataDenotation #-} in makeBuiltinMeaning unBDataDenotation - (runCostingFunOneArgument . paramUnBData) + (runCostingFunOneArgument . paramUnBData . ($ semvar)) - toBuiltinMeaning _semvar EqualsData = + toBuiltinMeaning semvar EqualsData = let equalsDataDenotation :: Data -> Data -> Bool equalsDataDenotation = (==) {-# INLINE equalsDataDenotation #-} in makeBuiltinMeaning equalsDataDenotation - (runCostingFunTwoArguments . paramEqualsData) + (runCostingFunTwoArguments . paramEqualsData . ($ semvar)) - toBuiltinMeaning _semvar SerialiseData = + toBuiltinMeaning semvar SerialiseData = let serialiseDataDenotation :: Data -> BS.ByteString serialiseDataDenotation = BSL.toStrict . serialise {-# INLINE serialiseDataDenotation #-} in makeBuiltinMeaning serialiseDataDenotation - (runCostingFunOneArgument . paramSerialiseData) + (runCostingFunOneArgument . paramSerialiseData . ($ semvar)) -- Misc constructors - toBuiltinMeaning _semvar MkPairData = + toBuiltinMeaning semvar MkPairData = let mkPairDataDenotation :: Data -> Data -> (Data, Data) mkPairDataDenotation = (,) {-# INLINE mkPairDataDenotation #-} in makeBuiltinMeaning mkPairDataDenotation - (runCostingFunTwoArguments . paramMkPairData) + (runCostingFunTwoArguments . paramMkPairData . ($ semvar)) - toBuiltinMeaning _semvar MkNilData = + toBuiltinMeaning semvar MkNilData = -- Nullary built-in functions don't work, so we need a unit argument. -- We don't really need this built-in function, see Note [Constants vs built-in functions], -- but we keep it around for historical reasons and convenience. @@ -1619,9 +1621,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkNilDataDenotation #-} in makeBuiltinMeaning mkNilDataDenotation - (runCostingFunOneArgument . paramMkNilData) + (runCostingFunOneArgument . paramMkNilData . ($ semvar)) - toBuiltinMeaning _semvar MkNilPairData = + toBuiltinMeaning semvar MkNilPairData = -- Nullary built-in functions don't work, so we need a unit argument. -- We don't really need this built-in function, see Note [Constants vs built-in functions], -- but we keep it around for historical reasons and convenience. @@ -1630,141 +1632,141 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkNilPairDataDenotation #-} in makeBuiltinMeaning mkNilPairDataDenotation - (runCostingFunOneArgument . paramMkNilPairData) + (runCostingFunOneArgument . paramMkNilPairData . ($ semvar)) -- BLS12_381.G1 - toBuiltinMeaning _semvar Bls12_381_G1_add = + toBuiltinMeaning semvar Bls12_381_G1_add = let bls12_381_G1_addDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_addDenotation = BLS12_381.G1.add {-# INLINE bls12_381_G1_addDenotation #-} in makeBuiltinMeaning bls12_381_G1_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_add) + (runCostingFunTwoArguments . paramBls12_381_G1_add . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_neg = + toBuiltinMeaning semvar Bls12_381_G1_neg = let bls12_381_G1_negDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_negDenotation = BLS12_381.G1.neg {-# INLINE bls12_381_G1_negDenotation #-} in makeBuiltinMeaning bls12_381_G1_negDenotation - (runCostingFunOneArgument . paramBls12_381_G1_neg) + (runCostingFunOneArgument . paramBls12_381_G1_neg . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_scalarMul = + toBuiltinMeaning semvar Bls12_381_G1_scalarMul = let bls12_381_G1_scalarMulDenotation :: Integer -> BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_scalarMulDenotation = BLS12_381.G1.scalarMul {-# INLINE bls12_381_G1_scalarMulDenotation #-} in makeBuiltinMeaning bls12_381_G1_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul) + (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_compress = + toBuiltinMeaning semvar Bls12_381_G1_compress = let bls12_381_G1_compressDenotation :: BLS12_381.G1.Element -> BS.ByteString bls12_381_G1_compressDenotation = BLS12_381.G1.compress {-# INLINE bls12_381_G1_compressDenotation #-} in makeBuiltinMeaning bls12_381_G1_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_compress) + (runCostingFunOneArgument . paramBls12_381_G1_compress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_uncompress = + toBuiltinMeaning semvar Bls12_381_G1_uncompress = let bls12_381_G1_uncompressDenotation :: BS.ByteString -> Emitter (EvaluationResult BLS12_381.G1.Element) bls12_381_G1_uncompressDenotation = eitherToEmitter . BLS12_381.G1.uncompress {-# INLINE bls12_381_G1_uncompressDenotation #-} in makeBuiltinMeaning bls12_381_G1_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_uncompress) + (runCostingFunOneArgument . paramBls12_381_G1_uncompress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_hashToGroup = + toBuiltinMeaning semvar Bls12_381_G1_hashToGroup = let bls12_381_G1_hashToGroupDenotation :: BS.ByteString -> BS.ByteString -> Emitter (EvaluationResult BLS12_381.G1.Element) bls12_381_G1_hashToGroupDenotation = eitherToEmitter .* BLS12_381.G1.hashToGroup {-# INLINE bls12_381_G1_hashToGroupDenotation #-} in makeBuiltinMeaning bls12_381_G1_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup) + (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_equal = + toBuiltinMeaning semvar Bls12_381_G1_equal = let bls12_381_G1_equalDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> Bool bls12_381_G1_equalDenotation = (==) {-# INLINE bls12_381_G1_equalDenotation #-} in makeBuiltinMeaning bls12_381_G1_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_equal) + (runCostingFunTwoArguments . paramBls12_381_G1_equal . ($ semvar)) -- BLS12_381.G2 - toBuiltinMeaning _semvar Bls12_381_G2_add = + toBuiltinMeaning semvar Bls12_381_G2_add = let bls12_381_G2_addDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_addDenotation = BLS12_381.G2.add {-# INLINE bls12_381_G2_addDenotation #-} in makeBuiltinMeaning bls12_381_G2_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_add) + (runCostingFunTwoArguments . paramBls12_381_G2_add . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_neg = + toBuiltinMeaning semvar Bls12_381_G2_neg = let bls12_381_G2_negDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_negDenotation = BLS12_381.G2.neg {-# INLINE bls12_381_G2_negDenotation #-} in makeBuiltinMeaning bls12_381_G2_negDenotation - (runCostingFunOneArgument . paramBls12_381_G2_neg) + (runCostingFunOneArgument . paramBls12_381_G2_neg . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_scalarMul = + toBuiltinMeaning semvar Bls12_381_G2_scalarMul = let bls12_381_G2_scalarMulDenotation :: Integer -> BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_scalarMulDenotation = BLS12_381.G2.scalarMul {-# INLINE bls12_381_G2_scalarMulDenotation #-} in makeBuiltinMeaning bls12_381_G2_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul) + (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_compress = + toBuiltinMeaning semvar Bls12_381_G2_compress = let bls12_381_G2_compressDenotation :: BLS12_381.G2.Element -> BS.ByteString bls12_381_G2_compressDenotation = BLS12_381.G2.compress {-# INLINE bls12_381_G2_compressDenotation #-} in makeBuiltinMeaning bls12_381_G2_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_compress) + (runCostingFunOneArgument . paramBls12_381_G2_compress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_uncompress = + toBuiltinMeaning semvar Bls12_381_G2_uncompress = let bls12_381_G2_uncompressDenotation :: BS.ByteString -> Emitter (EvaluationResult BLS12_381.G2.Element) bls12_381_G2_uncompressDenotation = eitherToEmitter . BLS12_381.G2.uncompress {-# INLINE bls12_381_G2_uncompressDenotation #-} in makeBuiltinMeaning bls12_381_G2_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_uncompress) + (runCostingFunOneArgument . paramBls12_381_G2_uncompress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_hashToGroup = + toBuiltinMeaning semvar Bls12_381_G2_hashToGroup = let bls12_381_G2_hashToGroupDenotation :: BS.ByteString -> BS.ByteString -> Emitter (EvaluationResult BLS12_381.G2.Element) bls12_381_G2_hashToGroupDenotation = eitherToEmitter .* BLS12_381.G2.hashToGroup {-# INLINE bls12_381_G2_hashToGroupDenotation #-} in makeBuiltinMeaning bls12_381_G2_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup) + (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_equal = + toBuiltinMeaning semvar Bls12_381_G2_equal = let bls12_381_G2_equalDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> Bool bls12_381_G2_equalDenotation = (==) {-# INLINE bls12_381_G2_equalDenotation #-} in makeBuiltinMeaning bls12_381_G2_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_equal) + (runCostingFunTwoArguments . paramBls12_381_G2_equal . ($ semvar)) -- BLS12_381.Pairing - toBuiltinMeaning _semvar Bls12_381_millerLoop = + toBuiltinMeaning semvar Bls12_381_millerLoop = let bls12_381_millerLoopDenotation :: BLS12_381.G1.Element -> BLS12_381.G2.Element -> BLS12_381.Pairing.MlResult bls12_381_millerLoopDenotation = BLS12_381.Pairing.millerLoop {-# INLINE bls12_381_millerLoopDenotation #-} in makeBuiltinMeaning bls12_381_millerLoopDenotation - (runCostingFunTwoArguments . paramBls12_381_millerLoop) + (runCostingFunTwoArguments . paramBls12_381_millerLoop . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_mulMlResult = + toBuiltinMeaning semvar Bls12_381_mulMlResult = let bls12_381_mulMlResultDenotation :: BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult @@ -1773,36 +1775,36 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE bls12_381_mulMlResultDenotation #-} in makeBuiltinMeaning bls12_381_mulMlResultDenotation - (runCostingFunTwoArguments . paramBls12_381_mulMlResult) + (runCostingFunTwoArguments . paramBls12_381_mulMlResult . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_finalVerify = + toBuiltinMeaning semvar Bls12_381_finalVerify = let bls12_381_finalVerifyDenotation :: BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult -> Bool bls12_381_finalVerifyDenotation = BLS12_381.Pairing.finalVerify {-# INLINE bls12_381_finalVerifyDenotation #-} in makeBuiltinMeaning bls12_381_finalVerifyDenotation - (runCostingFunTwoArguments . paramBls12_381_finalVerify) + (runCostingFunTwoArguments . paramBls12_381_finalVerify . ($ semvar)) - toBuiltinMeaning _semvar Keccak_256 = + toBuiltinMeaning semvar Keccak_256 = let keccak_256Denotation :: BS.ByteString -> BS.ByteString keccak_256Denotation = Hash.keccak_256 {-# INLINE keccak_256Denotation #-} in makeBuiltinMeaning keccak_256Denotation - (runCostingFunOneArgument . paramKeccak_256) + (runCostingFunOneArgument . paramKeccak_256 . ($ semvar)) - toBuiltinMeaning _semvar Blake2b_224 = + toBuiltinMeaning semvar Blake2b_224 = let blake2b_224Denotation :: BS.ByteString -> BS.ByteString blake2b_224Denotation = Hash.blake2b_224 {-# INLINE blake2b_224Denotation #-} in makeBuiltinMeaning blake2b_224Denotation - (runCostingFunOneArgument . paramBlake2b_224) + (runCostingFunOneArgument . paramBlake2b_224 . ($ semvar)) -- Conversions {- See Note [Input length limitation for IntegerToByteString] -} - toBuiltinMeaning _semvar IntegerToByteString = + toBuiltinMeaning semvar IntegerToByteString = let integerToByteStringDenotation :: Bool -> LiteralByteSize -> Integer -> BuiltinResult BS.ByteString {- The second argument is wrapped in a LiteralByteSize to allow us to interpret it as a size during costing. It appears as an integer in UPLC: see Note [Integral types as Integer]. -} @@ -1810,14 +1812,15 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE integerToByteStringDenotation #-} in makeBuiltinMeaning integerToByteStringDenotation - (runCostingFunThreeArguments . paramIntegerToByteString) - toBuiltinMeaning _semvar ByteStringToInteger = + (runCostingFunThreeArguments . paramIntegerToByteString . ($ semvar)) + + toBuiltinMeaning semvar ByteStringToInteger = let byteStringToIntegerDenotation :: Bool -> BS.ByteString -> Integer byteStringToIntegerDenotation = byteStringToIntegerWrapper {-# INLINE byteStringToIntegerDenotation #-} in makeBuiltinMeaning byteStringToIntegerDenotation - (runCostingFunTwoArguments . paramByteStringToInteger) + (runCostingFunTwoArguments . paramByteStringToInteger . ($ semvar)) -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 9a2843e7412..1ff4d39e563 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -34,8 +34,8 @@ import GHC.Magic (noinline) import PlutusPrelude -- | The default cost model for built-in functions. -defaultBuiltinCostModel :: BuiltinCostModel -defaultBuiltinCostModel = +defaultBuiltinCostModel :: BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel +defaultBuiltinCostModel _ = $$(readJSONFromFile DFP.builtinCostModelFile) {- Note [Modifying the cost model] @@ -76,13 +76,14 @@ defaultCekMachineCosts = evaluation the ledger passes a cost model to the Plutus Core evaluator using the `mkEvaluationContext` functions in PlutusLedgerApi. -} -defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel +defaultCekCostModel + :: CostModel CekMachineCosts (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel -- | 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 -defaultCostModelParams = extractCostModelParams defaultCekCostModel +defaultCostModelParams :: BuiltinSemanticsVariant DefaultFun -> Maybe CostModelParams +defaultCostModelParams semvar = extractCostModelParams $ sequence defaultCekCostModel semvar defaultCekParameters :: Typeable ann => MachineParameters CekMachineCosts (BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ann)) -- See Note [noinline for saving on ticks]. @@ -98,7 +99,7 @@ unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts (Builtins unitCekParameters = -- See Note [noinline for saving on ticks]. noinline mkMachineParameters def $ - CostModel unitCekMachineCosts unitCostBuiltinCostModel + CostModel unitCekMachineCosts (const unitCostBuiltinCostModel) defaultBuiltinsRuntimeForSemanticsVariant :: HasMeaningIn DefaultUni term diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index f2f86687fce..92a3c5be4f3 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -30,7 +30,7 @@ data CostModel machinecosts builtincosts = CostModel { _machineCostModel :: machinecosts , _builtinCostModel :: builtincosts - } deriving stock (Eq, Show) + } deriving stock (Eq, Show, Functor, Foldable, Traversable) makeLenses ''CostModel {-| At execution time we need a 'BuiltinsRuntime' object which includes both the From 8fa97cc90a5958518999cc1acf84d56db985b63a Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 22 Mar 2024 10:56:31 +0100 Subject: [PATCH 10/29] Revert "Make 'CostingPart' into a function" This reverts commit 21bb075a0308786107d50c32885d77e8bc25fe8b. --- .../src/PlutusCore/Default/Builtins.hs | 305 +++++++++--------- .../Evaluation/Machine/ExBudgetingDefaults.hs | 13 +- .../Evaluation/Machine/MachineParameters.hs | 2 +- 3 files changed, 158 insertions(+), 162 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 0c735634b14..8b1c1bac8f9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1069,7 +1069,7 @@ do it quite yet, even though it worked (the Plutus Tx part wasn't implemented). -} instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where - type CostingPart uni DefaultFun = BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel + type CostingPart uni DefaultFun = BuiltinCostModel {- | Allow different variants of builtins with different implementations, and possibly different semantics. Note that DefaultFunSemanticsVariant1, @@ -1086,96 +1086,96 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where :: forall val. HasMeaningIn uni val => BuiltinSemanticsVariant DefaultFun -> DefaultFun - -> BuiltinMeaning val (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) + -> BuiltinMeaning val BuiltinCostModel - toBuiltinMeaning semvar AddInteger = + toBuiltinMeaning _semvar AddInteger = let addIntegerDenotation :: Integer -> Integer -> Integer addIntegerDenotation = (+) {-# INLINE addIntegerDenotation #-} in makeBuiltinMeaning addIntegerDenotation - (runCostingFunTwoArguments . paramAddInteger . ($ semvar)) + (runCostingFunTwoArguments . paramAddInteger) - toBuiltinMeaning semvar SubtractInteger = + toBuiltinMeaning _semvar SubtractInteger = let subtractIntegerDenotation :: Integer -> Integer -> Integer subtractIntegerDenotation = (-) {-# INLINE subtractIntegerDenotation #-} in makeBuiltinMeaning subtractIntegerDenotation - (runCostingFunTwoArguments . paramSubtractInteger . ($ semvar)) + (runCostingFunTwoArguments . paramSubtractInteger) - toBuiltinMeaning semvar MultiplyInteger = + toBuiltinMeaning _semvar MultiplyInteger = let multiplyIntegerDenotation :: Integer -> Integer -> Integer multiplyIntegerDenotation = (*) {-# INLINE multiplyIntegerDenotation #-} in makeBuiltinMeaning multiplyIntegerDenotation - (runCostingFunTwoArguments . paramMultiplyInteger . ($ semvar)) + (runCostingFunTwoArguments . paramMultiplyInteger) - toBuiltinMeaning semvar DivideInteger = + toBuiltinMeaning _semvar DivideInteger = let divideIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer divideIntegerDenotation = nonZeroSecondArg div {-# INLINE divideIntegerDenotation #-} in makeBuiltinMeaning divideIntegerDenotation - (runCostingFunTwoArguments . paramDivideInteger . ($ semvar)) + (runCostingFunTwoArguments . paramDivideInteger) - toBuiltinMeaning semvar QuotientInteger = + toBuiltinMeaning _semvar QuotientInteger = let quotientIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer quotientIntegerDenotation = nonZeroSecondArg quot {-# INLINE quotientIntegerDenotation #-} in makeBuiltinMeaning quotientIntegerDenotation - (runCostingFunTwoArguments . paramQuotientInteger . ($ semvar)) + (runCostingFunTwoArguments . paramQuotientInteger) - toBuiltinMeaning semvar RemainderInteger = + toBuiltinMeaning _semvar RemainderInteger = let remainderIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer remainderIntegerDenotation = nonZeroSecondArg rem {-# INLINE remainderIntegerDenotation #-} in makeBuiltinMeaning remainderIntegerDenotation - (runCostingFunTwoArguments . paramRemainderInteger . ($ semvar)) + (runCostingFunTwoArguments . paramRemainderInteger) - toBuiltinMeaning semvar ModInteger = + toBuiltinMeaning _semvar ModInteger = let modIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer modIntegerDenotation = nonZeroSecondArg mod {-# INLINE modIntegerDenotation #-} in makeBuiltinMeaning modIntegerDenotation - (runCostingFunTwoArguments . paramModInteger . ($ semvar)) + (runCostingFunTwoArguments . paramModInteger) - toBuiltinMeaning semvar EqualsInteger = + toBuiltinMeaning _semvar EqualsInteger = let equalsIntegerDenotation :: Integer -> Integer -> Bool equalsIntegerDenotation = (==) {-# INLINE equalsIntegerDenotation #-} in makeBuiltinMeaning equalsIntegerDenotation - (runCostingFunTwoArguments . paramEqualsInteger . ($ semvar)) + (runCostingFunTwoArguments . paramEqualsInteger) - toBuiltinMeaning semvar LessThanInteger = + toBuiltinMeaning _semvar LessThanInteger = let lessThanIntegerDenotation :: Integer -> Integer -> Bool lessThanIntegerDenotation = (<) {-# INLINE lessThanIntegerDenotation #-} in makeBuiltinMeaning lessThanIntegerDenotation - (runCostingFunTwoArguments . paramLessThanInteger . ($ semvar)) + (runCostingFunTwoArguments . paramLessThanInteger) - toBuiltinMeaning semvar LessThanEqualsInteger = + toBuiltinMeaning _semvar LessThanEqualsInteger = let lessThanEqualsIntegerDenotation :: Integer -> Integer -> Bool lessThanEqualsIntegerDenotation = (<=) {-# INLINE lessThanEqualsIntegerDenotation #-} in makeBuiltinMeaning lessThanEqualsIntegerDenotation - (runCostingFunTwoArguments . paramLessThanEqualsInteger . ($ semvar)) + (runCostingFunTwoArguments . paramLessThanEqualsInteger) -- Bytestrings - toBuiltinMeaning semvar AppendByteString = + toBuiltinMeaning _semvar AppendByteString = let appendByteStringDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString appendByteStringDenotation = BS.append {-# INLINE appendByteStringDenotation #-} in makeBuiltinMeaning appendByteStringDenotation - (runCostingFunTwoArguments . paramAppendByteString . ($ semvar)) + (runCostingFunTwoArguments . paramAppendByteString) -- See Note [Builtin semantics variants] toBuiltinMeaning semvar ConsByteString = @@ -1184,10 +1184,8 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- different types ('Integer' vs 'Word8'), the costing function needs to -- by polymorphic over the type of constant. let costingFun - :: ExMemoryUsage a - => (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) - -> a -> BS.ByteString -> ExBudgetStream - costingFun = runCostingFunTwoArguments . paramConsByteString . ($ semvar) + :: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream + costingFun = runCostingFunTwoArguments . paramConsByteString {-# INLINE costingFun #-} consByteStringMeaning_V1 = let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString @@ -1210,23 +1208,23 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where DefaultFunSemanticsVariant1 -> consByteStringMeaning_V1 DefaultFunSemanticsVariant2 -> consByteStringMeaning_V2 - toBuiltinMeaning semvar SliceByteString = + toBuiltinMeaning _semvar SliceByteString = let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString sliceByteStringDenotation start n xs = BS.take n (BS.drop start xs) {-# INLINE sliceByteStringDenotation #-} in makeBuiltinMeaning sliceByteStringDenotation - (runCostingFunThreeArguments . paramSliceByteString . ($ semvar)) + (runCostingFunThreeArguments . paramSliceByteString) - toBuiltinMeaning semvar LengthOfByteString = + toBuiltinMeaning _semvar LengthOfByteString = let lengthOfByteStringDenotation :: BS.ByteString -> Int lengthOfByteStringDenotation = BS.length {-# INLINE lengthOfByteStringDenotation #-} in makeBuiltinMeaning lengthOfByteStringDenotation - (runCostingFunOneArgument . paramLengthOfByteString . ($ semvar)) + (runCostingFunOneArgument . paramLengthOfByteString) - toBuiltinMeaning semvar IndexByteString = + toBuiltinMeaning _semvar IndexByteString = let indexByteStringDenotation :: BS.ByteString -> Int -> EvaluationResult Word8 indexByteStringDenotation xs n = do -- TODO: fix this mess with @indexMaybe@ from @bytestring >= 0.11.0.0@. @@ -1235,56 +1233,56 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE indexByteStringDenotation #-} in makeBuiltinMeaning indexByteStringDenotation - (runCostingFunTwoArguments . paramIndexByteString . ($ semvar)) + (runCostingFunTwoArguments . paramIndexByteString) - toBuiltinMeaning semvar EqualsByteString = + toBuiltinMeaning _semvar EqualsByteString = let equalsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool equalsByteStringDenotation = (==) {-# INLINE equalsByteStringDenotation #-} in makeBuiltinMeaning equalsByteStringDenotation - (runCostingFunTwoArguments . paramEqualsByteString . ($ semvar)) + (runCostingFunTwoArguments . paramEqualsByteString) - toBuiltinMeaning semvar LessThanByteString = + toBuiltinMeaning _semvar LessThanByteString = let lessThanByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool lessThanByteStringDenotation = (<) {-# INLINE lessThanByteStringDenotation #-} in makeBuiltinMeaning lessThanByteStringDenotation - (runCostingFunTwoArguments . paramLessThanByteString . ($ semvar)) + (runCostingFunTwoArguments . paramLessThanByteString) - toBuiltinMeaning semvar LessThanEqualsByteString = + toBuiltinMeaning _semvar LessThanEqualsByteString = let lessThanEqualsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool lessThanEqualsByteStringDenotation = (<=) {-# INLINE lessThanEqualsByteStringDenotation #-} in makeBuiltinMeaning lessThanEqualsByteStringDenotation - (runCostingFunTwoArguments . paramLessThanEqualsByteString . ($ semvar)) + (runCostingFunTwoArguments . paramLessThanEqualsByteString) -- Cryptography and hashes - toBuiltinMeaning semvar Sha2_256 = + toBuiltinMeaning _semvar Sha2_256 = let sha2_256Denotation :: BS.ByteString -> BS.ByteString sha2_256Denotation = Hash.sha2_256 {-# INLINE sha2_256Denotation #-} in makeBuiltinMeaning sha2_256Denotation - (runCostingFunOneArgument . paramSha2_256 . ($ semvar)) + (runCostingFunOneArgument . paramSha2_256) - toBuiltinMeaning semvar Sha3_256 = + toBuiltinMeaning _semvar Sha3_256 = let sha3_256Denotation :: BS.ByteString -> BS.ByteString sha3_256Denotation = Hash.sha3_256 {-# INLINE sha3_256Denotation #-} in makeBuiltinMeaning sha3_256Denotation - (runCostingFunOneArgument . paramSha3_256 . ($ semvar)) + (runCostingFunOneArgument . paramSha3_256) - toBuiltinMeaning semvar Blake2b_256 = + toBuiltinMeaning _semvar Blake2b_256 = let blake2b_256Denotation :: BS.ByteString -> BS.ByteString blake2b_256Denotation = Hash.blake2b_256 {-# INLINE blake2b_256Denotation #-} in makeBuiltinMeaning blake2b_256Denotation - (runCostingFunOneArgument . paramBlake2b_256 . ($ semvar)) + (runCostingFunOneArgument . paramBlake2b_256) toBuiltinMeaning semvar VerifyEd25519Signature = let verifyEd25519SignatureDenotation @@ -1300,7 +1298,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- Benchmarks indicate that the two variants have very similar -- execution times, so it's safe to use the same costing function for -- both. - (runCostingFunThreeArguments . paramVerifyEd25519Signature . ($ semvar)) + (runCostingFunThreeArguments . paramVerifyEd25519Signature) {- Note [ECDSA secp256k1 signature verification]. An ECDSA signature consists of a pair of values (r,s), and for each value of r there are in @@ -1318,86 +1316,86 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where https://github.com/bitcoin-core/secp256k1. -} - toBuiltinMeaning semvar VerifyEcdsaSecp256k1Signature = + toBuiltinMeaning _semvar VerifyEcdsaSecp256k1Signature = let verifyEcdsaSecp256k1SignatureDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool verifyEcdsaSecp256k1SignatureDenotation = verifyEcdsaSecp256k1Signature {-# INLINE verifyEcdsaSecp256k1SignatureDenotation #-} in makeBuiltinMeaning verifyEcdsaSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature . ($ semvar)) + (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature) - toBuiltinMeaning semvar VerifySchnorrSecp256k1Signature = + toBuiltinMeaning _semvar VerifySchnorrSecp256k1Signature = let verifySchnorrSecp256k1SignatureDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool verifySchnorrSecp256k1SignatureDenotation = verifySchnorrSecp256k1Signature {-# INLINE verifySchnorrSecp256k1SignatureDenotation #-} in makeBuiltinMeaning verifySchnorrSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature . ($ semvar)) + (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature) -- Strings - toBuiltinMeaning semvar AppendString = + toBuiltinMeaning _semvar AppendString = let appendStringDenotation :: Text -> Text -> Text appendStringDenotation = (<>) {-# INLINE appendStringDenotation #-} in makeBuiltinMeaning appendStringDenotation - (runCostingFunTwoArguments . paramAppendString . ($ semvar)) + (runCostingFunTwoArguments . paramAppendString) - toBuiltinMeaning semvar EqualsString = + toBuiltinMeaning _semvar EqualsString = let equalsStringDenotation :: Text -> Text -> Bool equalsStringDenotation = (==) {-# INLINE equalsStringDenotation #-} in makeBuiltinMeaning equalsStringDenotation - (runCostingFunTwoArguments . paramEqualsString . ($ semvar)) + (runCostingFunTwoArguments . paramEqualsString) - toBuiltinMeaning semvar EncodeUtf8 = + toBuiltinMeaning _semvar EncodeUtf8 = let encodeUtf8Denotation :: Text -> BS.ByteString encodeUtf8Denotation = encodeUtf8 {-# INLINE encodeUtf8Denotation #-} in makeBuiltinMeaning encodeUtf8Denotation - (runCostingFunOneArgument . paramEncodeUtf8 . ($ semvar)) + (runCostingFunOneArgument . paramEncodeUtf8) - toBuiltinMeaning semvar DecodeUtf8 = + toBuiltinMeaning _semvar DecodeUtf8 = let decodeUtf8Denotation :: BS.ByteString -> EvaluationResult Text decodeUtf8Denotation = reoption . decodeUtf8' {-# INLINE decodeUtf8Denotation #-} in makeBuiltinMeaning decodeUtf8Denotation - (runCostingFunOneArgument . paramDecodeUtf8 . ($ semvar)) + (runCostingFunOneArgument . paramDecodeUtf8) -- Bool - toBuiltinMeaning semvar IfThenElse = + toBuiltinMeaning _semvar IfThenElse = let ifThenElseDenotation :: Bool -> a -> a -> a ifThenElseDenotation b x y = if b then x else y {-# INLINE ifThenElseDenotation #-} in makeBuiltinMeaning ifThenElseDenotation - (runCostingFunThreeArguments . paramIfThenElse . ($ semvar)) + (runCostingFunThreeArguments . paramIfThenElse) -- Unit - toBuiltinMeaning semvar ChooseUnit = + toBuiltinMeaning _semvar ChooseUnit = let chooseUnitDenotation :: () -> a -> a chooseUnitDenotation () x = x {-# INLINE chooseUnitDenotation #-} in makeBuiltinMeaning chooseUnitDenotation - (runCostingFunTwoArguments . paramChooseUnit . ($ semvar)) + (runCostingFunTwoArguments . paramChooseUnit) -- Tracing - toBuiltinMeaning semvar Trace = + toBuiltinMeaning _semvar Trace = let traceDenotation :: Text -> a -> Emitter a traceDenotation text a = a <$ emit text {-# INLINE traceDenotation #-} in makeBuiltinMeaning traceDenotation - (runCostingFunTwoArguments . paramTrace . ($ semvar)) + (runCostingFunTwoArguments . paramTrace) -- Pairs - toBuiltinMeaning semvar FstPair = + toBuiltinMeaning _semvar FstPair = let fstPairDenotation :: SomeConstant uni (a, b) -> EvaluationResult (Opaque val a) fstPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = do DefaultUniPair uniA _ <- pure uniPairAB @@ -1405,9 +1403,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE fstPairDenotation #-} in makeBuiltinMeaning fstPairDenotation - (runCostingFunOneArgument . paramFstPair . ($ semvar)) + (runCostingFunOneArgument . paramFstPair) - toBuiltinMeaning semvar SndPair = + toBuiltinMeaning _semvar SndPair = let sndPairDenotation :: SomeConstant uni (a, b) -> EvaluationResult (Opaque val b) sndPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = do DefaultUniPair _ uniB <- pure uniPairAB @@ -1415,10 +1413,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE sndPairDenotation #-} in makeBuiltinMeaning sndPairDenotation - (runCostingFunOneArgument . paramSndPair . ($ semvar)) + (runCostingFunOneArgument . paramSndPair) -- Lists - toBuiltinMeaning semvar ChooseList = + toBuiltinMeaning _semvar ChooseList = let chooseListDenotation :: SomeConstant uni [a] -> b -> b -> EvaluationResult b chooseListDenotation (SomeConstant (Some (ValueOf uniListA xs))) a b = do DefaultUniList _ <- pure uniListA @@ -1428,9 +1426,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE chooseListDenotation #-} in makeBuiltinMeaning chooseListDenotation - (runCostingFunThreeArguments . paramChooseList . ($ semvar)) + (runCostingFunThreeArguments . paramChooseList) - toBuiltinMeaning semvar MkCons = + toBuiltinMeaning _semvar MkCons = let mkConsDenotation :: SomeConstant uni a -> SomeConstant uni [a] -> EvaluationResult (Opaque val [a]) mkConsDenotation @@ -1448,9 +1446,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkConsDenotation #-} in makeBuiltinMeaning mkConsDenotation - (runCostingFunTwoArguments . paramMkCons . ($ semvar)) + (runCostingFunTwoArguments . paramMkCons) - toBuiltinMeaning semvar HeadList = + toBuiltinMeaning _semvar HeadList = let headListDenotation :: SomeConstant uni [a] -> EvaluationResult (Opaque val a) headListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList uniA <- pure uniListA @@ -1459,9 +1457,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE headListDenotation #-} in makeBuiltinMeaning headListDenotation - (runCostingFunOneArgument . paramHeadList . ($ semvar)) + (runCostingFunOneArgument . paramHeadList) - toBuiltinMeaning semvar TailList = + toBuiltinMeaning _semvar TailList = let tailListDenotation :: SomeConstant uni [a] -> EvaluationResult (Opaque val [a]) tailListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList _ <- pure uniListA @@ -1470,9 +1468,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE tailListDenotation #-} in makeBuiltinMeaning tailListDenotation - (runCostingFunOneArgument . paramTailList . ($ semvar)) + (runCostingFunOneArgument . paramTailList) - toBuiltinMeaning semvar NullList = + toBuiltinMeaning _semvar NullList = let nullListDenotation :: SomeConstant uni [a] -> EvaluationResult Bool nullListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList _ <- pure uniListA @@ -1480,10 +1478,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE nullListDenotation #-} in makeBuiltinMeaning nullListDenotation - (runCostingFunOneArgument . paramNullList . ($ semvar)) + (runCostingFunOneArgument . paramNullList) -- Data - toBuiltinMeaning semvar ChooseData = + toBuiltinMeaning _semvar ChooseData = let chooseDataDenotation :: Data -> a -> a -> a -> a -> a -> a chooseDataDenotation d xConstr xMap xList xI xB = case d of @@ -1495,49 +1493,49 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE chooseDataDenotation #-} in makeBuiltinMeaning chooseDataDenotation - (runCostingFunSixArguments . paramChooseData . ($ semvar)) + (runCostingFunSixArguments . paramChooseData) - toBuiltinMeaning semvar ConstrData = + toBuiltinMeaning _semvar ConstrData = let constrDataDenotation :: Integer -> [Data] -> Data constrDataDenotation = Constr {-# INLINE constrDataDenotation #-} in makeBuiltinMeaning constrDataDenotation - (runCostingFunTwoArguments . paramConstrData . ($ semvar)) + (runCostingFunTwoArguments . paramConstrData) - toBuiltinMeaning semvar MapData = + toBuiltinMeaning _semvar MapData = let mapDataDenotation :: [(Data, Data)] -> Data mapDataDenotation = Map {-# INLINE mapDataDenotation #-} in makeBuiltinMeaning mapDataDenotation - (runCostingFunOneArgument . paramMapData . ($ semvar)) + (runCostingFunOneArgument . paramMapData) - toBuiltinMeaning semvar ListData = + toBuiltinMeaning _semvar ListData = let listDataDenotation :: [Data] -> Data listDataDenotation = List {-# INLINE listDataDenotation #-} in makeBuiltinMeaning listDataDenotation - (runCostingFunOneArgument . paramListData . ($ semvar)) + (runCostingFunOneArgument . paramListData) - toBuiltinMeaning semvar IData = + toBuiltinMeaning _semvar IData = let iDataDenotation :: Integer -> Data iDataDenotation = I {-# INLINE iDataDenotation #-} in makeBuiltinMeaning iDataDenotation - (runCostingFunOneArgument . paramIData . ($ semvar)) + (runCostingFunOneArgument . paramIData) - toBuiltinMeaning semvar BData = + toBuiltinMeaning _semvar BData = let bDataDenotation :: BS.ByteString -> Data bDataDenotation = B {-# INLINE bDataDenotation #-} in makeBuiltinMeaning bDataDenotation - (runCostingFunOneArgument . paramBData . ($ semvar)) + (runCostingFunOneArgument . paramBData) - toBuiltinMeaning semvar UnConstrData = + toBuiltinMeaning _semvar UnConstrData = let unConstrDataDenotation :: Data -> EvaluationResult (Integer, [Data]) unConstrDataDenotation = \case Constr i ds -> EvaluationSuccess (i, ds) @@ -1545,9 +1543,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unConstrDataDenotation #-} in makeBuiltinMeaning unConstrDataDenotation - (runCostingFunOneArgument . paramUnConstrData . ($ semvar)) + (runCostingFunOneArgument . paramUnConstrData) - toBuiltinMeaning semvar UnMapData = + toBuiltinMeaning _semvar UnMapData = let unMapDataDenotation :: Data -> EvaluationResult [(Data, Data)] unMapDataDenotation = \case Map es -> EvaluationSuccess es @@ -1555,9 +1553,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unMapDataDenotation #-} in makeBuiltinMeaning unMapDataDenotation - (runCostingFunOneArgument . paramUnMapData . ($ semvar)) + (runCostingFunOneArgument . paramUnMapData) - toBuiltinMeaning semvar UnListData = + toBuiltinMeaning _semvar UnListData = let unListDataDenotation :: Data -> EvaluationResult [Data] unListDataDenotation = \case List ds -> EvaluationSuccess ds @@ -1565,9 +1563,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unListDataDenotation #-} in makeBuiltinMeaning unListDataDenotation - (runCostingFunOneArgument . paramUnListData . ($ semvar)) + (runCostingFunOneArgument . paramUnListData) - toBuiltinMeaning semvar UnIData = + toBuiltinMeaning _semvar UnIData = let unIDataDenotation :: Data -> EvaluationResult Integer unIDataDenotation = \case I i -> EvaluationSuccess i @@ -1575,9 +1573,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unIDataDenotation #-} in makeBuiltinMeaning unIDataDenotation - (runCostingFunOneArgument . paramUnIData . ($ semvar)) + (runCostingFunOneArgument . paramUnIData) - toBuiltinMeaning semvar UnBData = + toBuiltinMeaning _semvar UnBData = let unBDataDenotation :: Data -> EvaluationResult BS.ByteString unBDataDenotation = \case B b -> EvaluationSuccess b @@ -1585,34 +1583,34 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unBDataDenotation #-} in makeBuiltinMeaning unBDataDenotation - (runCostingFunOneArgument . paramUnBData . ($ semvar)) + (runCostingFunOneArgument . paramUnBData) - toBuiltinMeaning semvar EqualsData = + toBuiltinMeaning _semvar EqualsData = let equalsDataDenotation :: Data -> Data -> Bool equalsDataDenotation = (==) {-# INLINE equalsDataDenotation #-} in makeBuiltinMeaning equalsDataDenotation - (runCostingFunTwoArguments . paramEqualsData . ($ semvar)) + (runCostingFunTwoArguments . paramEqualsData) - toBuiltinMeaning semvar SerialiseData = + toBuiltinMeaning _semvar SerialiseData = let serialiseDataDenotation :: Data -> BS.ByteString serialiseDataDenotation = BSL.toStrict . serialise {-# INLINE serialiseDataDenotation #-} in makeBuiltinMeaning serialiseDataDenotation - (runCostingFunOneArgument . paramSerialiseData . ($ semvar)) + (runCostingFunOneArgument . paramSerialiseData) -- Misc constructors - toBuiltinMeaning semvar MkPairData = + toBuiltinMeaning _semvar MkPairData = let mkPairDataDenotation :: Data -> Data -> (Data, Data) mkPairDataDenotation = (,) {-# INLINE mkPairDataDenotation #-} in makeBuiltinMeaning mkPairDataDenotation - (runCostingFunTwoArguments . paramMkPairData . ($ semvar)) + (runCostingFunTwoArguments . paramMkPairData) - toBuiltinMeaning semvar MkNilData = + toBuiltinMeaning _semvar MkNilData = -- Nullary built-in functions don't work, so we need a unit argument. -- We don't really need this built-in function, see Note [Constants vs built-in functions], -- but we keep it around for historical reasons and convenience. @@ -1621,9 +1619,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkNilDataDenotation #-} in makeBuiltinMeaning mkNilDataDenotation - (runCostingFunOneArgument . paramMkNilData . ($ semvar)) + (runCostingFunOneArgument . paramMkNilData) - toBuiltinMeaning semvar MkNilPairData = + toBuiltinMeaning _semvar MkNilPairData = -- Nullary built-in functions don't work, so we need a unit argument. -- We don't really need this built-in function, see Note [Constants vs built-in functions], -- but we keep it around for historical reasons and convenience. @@ -1632,141 +1630,141 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkNilPairDataDenotation #-} in makeBuiltinMeaning mkNilPairDataDenotation - (runCostingFunOneArgument . paramMkNilPairData . ($ semvar)) + (runCostingFunOneArgument . paramMkNilPairData) -- BLS12_381.G1 - toBuiltinMeaning semvar Bls12_381_G1_add = + toBuiltinMeaning _semvar Bls12_381_G1_add = let bls12_381_G1_addDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_addDenotation = BLS12_381.G1.add {-# INLINE bls12_381_G1_addDenotation #-} in makeBuiltinMeaning bls12_381_G1_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_add . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G1_add) - toBuiltinMeaning semvar Bls12_381_G1_neg = + toBuiltinMeaning _semvar Bls12_381_G1_neg = let bls12_381_G1_negDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_negDenotation = BLS12_381.G1.neg {-# INLINE bls12_381_G1_negDenotation #-} in makeBuiltinMeaning bls12_381_G1_negDenotation - (runCostingFunOneArgument . paramBls12_381_G1_neg . ($ semvar)) + (runCostingFunOneArgument . paramBls12_381_G1_neg) - toBuiltinMeaning semvar Bls12_381_G1_scalarMul = + toBuiltinMeaning _semvar Bls12_381_G1_scalarMul = let bls12_381_G1_scalarMulDenotation :: Integer -> BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_scalarMulDenotation = BLS12_381.G1.scalarMul {-# INLINE bls12_381_G1_scalarMulDenotation #-} in makeBuiltinMeaning bls12_381_G1_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul) - toBuiltinMeaning semvar Bls12_381_G1_compress = + toBuiltinMeaning _semvar Bls12_381_G1_compress = let bls12_381_G1_compressDenotation :: BLS12_381.G1.Element -> BS.ByteString bls12_381_G1_compressDenotation = BLS12_381.G1.compress {-# INLINE bls12_381_G1_compressDenotation #-} in makeBuiltinMeaning bls12_381_G1_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_compress . ($ semvar)) + (runCostingFunOneArgument . paramBls12_381_G1_compress) - toBuiltinMeaning semvar Bls12_381_G1_uncompress = + toBuiltinMeaning _semvar Bls12_381_G1_uncompress = let bls12_381_G1_uncompressDenotation :: BS.ByteString -> Emitter (EvaluationResult BLS12_381.G1.Element) bls12_381_G1_uncompressDenotation = eitherToEmitter . BLS12_381.G1.uncompress {-# INLINE bls12_381_G1_uncompressDenotation #-} in makeBuiltinMeaning bls12_381_G1_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_uncompress . ($ semvar)) + (runCostingFunOneArgument . paramBls12_381_G1_uncompress) - toBuiltinMeaning semvar Bls12_381_G1_hashToGroup = + toBuiltinMeaning _semvar Bls12_381_G1_hashToGroup = let bls12_381_G1_hashToGroupDenotation :: BS.ByteString -> BS.ByteString -> Emitter (EvaluationResult BLS12_381.G1.Element) bls12_381_G1_hashToGroupDenotation = eitherToEmitter .* BLS12_381.G1.hashToGroup {-# INLINE bls12_381_G1_hashToGroupDenotation #-} in makeBuiltinMeaning bls12_381_G1_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup) - toBuiltinMeaning semvar Bls12_381_G1_equal = + toBuiltinMeaning _semvar Bls12_381_G1_equal = let bls12_381_G1_equalDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> Bool bls12_381_G1_equalDenotation = (==) {-# INLINE bls12_381_G1_equalDenotation #-} in makeBuiltinMeaning bls12_381_G1_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_equal . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G1_equal) -- BLS12_381.G2 - toBuiltinMeaning semvar Bls12_381_G2_add = + toBuiltinMeaning _semvar Bls12_381_G2_add = let bls12_381_G2_addDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_addDenotation = BLS12_381.G2.add {-# INLINE bls12_381_G2_addDenotation #-} in makeBuiltinMeaning bls12_381_G2_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_add . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G2_add) - toBuiltinMeaning semvar Bls12_381_G2_neg = + toBuiltinMeaning _semvar Bls12_381_G2_neg = let bls12_381_G2_negDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_negDenotation = BLS12_381.G2.neg {-# INLINE bls12_381_G2_negDenotation #-} in makeBuiltinMeaning bls12_381_G2_negDenotation - (runCostingFunOneArgument . paramBls12_381_G2_neg . ($ semvar)) + (runCostingFunOneArgument . paramBls12_381_G2_neg) - toBuiltinMeaning semvar Bls12_381_G2_scalarMul = + toBuiltinMeaning _semvar Bls12_381_G2_scalarMul = let bls12_381_G2_scalarMulDenotation :: Integer -> BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_scalarMulDenotation = BLS12_381.G2.scalarMul {-# INLINE bls12_381_G2_scalarMulDenotation #-} in makeBuiltinMeaning bls12_381_G2_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul) - toBuiltinMeaning semvar Bls12_381_G2_compress = + toBuiltinMeaning _semvar Bls12_381_G2_compress = let bls12_381_G2_compressDenotation :: BLS12_381.G2.Element -> BS.ByteString bls12_381_G2_compressDenotation = BLS12_381.G2.compress {-# INLINE bls12_381_G2_compressDenotation #-} in makeBuiltinMeaning bls12_381_G2_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_compress . ($ semvar)) + (runCostingFunOneArgument . paramBls12_381_G2_compress) - toBuiltinMeaning semvar Bls12_381_G2_uncompress = + toBuiltinMeaning _semvar Bls12_381_G2_uncompress = let bls12_381_G2_uncompressDenotation :: BS.ByteString -> Emitter (EvaluationResult BLS12_381.G2.Element) bls12_381_G2_uncompressDenotation = eitherToEmitter . BLS12_381.G2.uncompress {-# INLINE bls12_381_G2_uncompressDenotation #-} in makeBuiltinMeaning bls12_381_G2_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_uncompress . ($ semvar)) + (runCostingFunOneArgument . paramBls12_381_G2_uncompress) - toBuiltinMeaning semvar Bls12_381_G2_hashToGroup = + toBuiltinMeaning _semvar Bls12_381_G2_hashToGroup = let bls12_381_G2_hashToGroupDenotation :: BS.ByteString -> BS.ByteString -> Emitter (EvaluationResult BLS12_381.G2.Element) bls12_381_G2_hashToGroupDenotation = eitherToEmitter .* BLS12_381.G2.hashToGroup {-# INLINE bls12_381_G2_hashToGroupDenotation #-} in makeBuiltinMeaning bls12_381_G2_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup) - toBuiltinMeaning semvar Bls12_381_G2_equal = + toBuiltinMeaning _semvar Bls12_381_G2_equal = let bls12_381_G2_equalDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> Bool bls12_381_G2_equalDenotation = (==) {-# INLINE bls12_381_G2_equalDenotation #-} in makeBuiltinMeaning bls12_381_G2_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_equal . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_G2_equal) -- BLS12_381.Pairing - toBuiltinMeaning semvar Bls12_381_millerLoop = + toBuiltinMeaning _semvar Bls12_381_millerLoop = let bls12_381_millerLoopDenotation :: BLS12_381.G1.Element -> BLS12_381.G2.Element -> BLS12_381.Pairing.MlResult bls12_381_millerLoopDenotation = BLS12_381.Pairing.millerLoop {-# INLINE bls12_381_millerLoopDenotation #-} in makeBuiltinMeaning bls12_381_millerLoopDenotation - (runCostingFunTwoArguments . paramBls12_381_millerLoop . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_millerLoop) - toBuiltinMeaning semvar Bls12_381_mulMlResult = + toBuiltinMeaning _semvar Bls12_381_mulMlResult = let bls12_381_mulMlResultDenotation :: BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult @@ -1775,36 +1773,36 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE bls12_381_mulMlResultDenotation #-} in makeBuiltinMeaning bls12_381_mulMlResultDenotation - (runCostingFunTwoArguments . paramBls12_381_mulMlResult . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_mulMlResult) - toBuiltinMeaning semvar Bls12_381_finalVerify = + toBuiltinMeaning _semvar Bls12_381_finalVerify = let bls12_381_finalVerifyDenotation :: BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult -> Bool bls12_381_finalVerifyDenotation = BLS12_381.Pairing.finalVerify {-# INLINE bls12_381_finalVerifyDenotation #-} in makeBuiltinMeaning bls12_381_finalVerifyDenotation - (runCostingFunTwoArguments . paramBls12_381_finalVerify . ($ semvar)) + (runCostingFunTwoArguments . paramBls12_381_finalVerify) - toBuiltinMeaning semvar Keccak_256 = + toBuiltinMeaning _semvar Keccak_256 = let keccak_256Denotation :: BS.ByteString -> BS.ByteString keccak_256Denotation = Hash.keccak_256 {-# INLINE keccak_256Denotation #-} in makeBuiltinMeaning keccak_256Denotation - (runCostingFunOneArgument . paramKeccak_256 . ($ semvar)) + (runCostingFunOneArgument . paramKeccak_256) - toBuiltinMeaning semvar Blake2b_224 = + toBuiltinMeaning _semvar Blake2b_224 = let blake2b_224Denotation :: BS.ByteString -> BS.ByteString blake2b_224Denotation = Hash.blake2b_224 {-# INLINE blake2b_224Denotation #-} in makeBuiltinMeaning blake2b_224Denotation - (runCostingFunOneArgument . paramBlake2b_224 . ($ semvar)) + (runCostingFunOneArgument . paramBlake2b_224) -- Conversions {- See Note [Input length limitation for IntegerToByteString] -} - toBuiltinMeaning semvar IntegerToByteString = + toBuiltinMeaning _semvar IntegerToByteString = let integerToByteStringDenotation :: Bool -> LiteralByteSize -> Integer -> BuiltinResult BS.ByteString {- The second argument is wrapped in a LiteralByteSize to allow us to interpret it as a size during costing. It appears as an integer in UPLC: see Note [Integral types as Integer]. -} @@ -1812,15 +1810,14 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE integerToByteStringDenotation #-} in makeBuiltinMeaning integerToByteStringDenotation - (runCostingFunThreeArguments . paramIntegerToByteString . ($ semvar)) - - toBuiltinMeaning semvar ByteStringToInteger = + (runCostingFunThreeArguments . paramIntegerToByteString) + toBuiltinMeaning _semvar ByteStringToInteger = let byteStringToIntegerDenotation :: Bool -> BS.ByteString -> Integer byteStringToIntegerDenotation = byteStringToIntegerWrapper {-# INLINE byteStringToIntegerDenotation #-} in makeBuiltinMeaning byteStringToIntegerDenotation - (runCostingFunTwoArguments . paramByteStringToInteger . ($ semvar)) + (runCostingFunTwoArguments . paramByteStringToInteger) -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 1ff4d39e563..9a2843e7412 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -34,8 +34,8 @@ import GHC.Magic (noinline) import PlutusPrelude -- | The default cost model for built-in functions. -defaultBuiltinCostModel :: BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel -defaultBuiltinCostModel _ = +defaultBuiltinCostModel :: BuiltinCostModel +defaultBuiltinCostModel = $$(readJSONFromFile DFP.builtinCostModelFile) {- Note [Modifying the cost model] @@ -76,14 +76,13 @@ defaultCekMachineCosts = evaluation the ledger passes a cost model to the Plutus Core evaluator using the `mkEvaluationContext` functions in PlutusLedgerApi. -} -defaultCekCostModel - :: CostModel CekMachineCosts (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) +defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel -- | The default cost model data. This is exposed to the ledger, so let's not -- confuse anybody by mentioning the CEK machine -defaultCostModelParams :: BuiltinSemanticsVariant DefaultFun -> Maybe CostModelParams -defaultCostModelParams semvar = extractCostModelParams $ sequence defaultCekCostModel semvar +defaultCostModelParams :: Maybe CostModelParams +defaultCostModelParams = extractCostModelParams defaultCekCostModel defaultCekParameters :: Typeable ann => MachineParameters CekMachineCosts (BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ann)) -- See Note [noinline for saving on ticks]. @@ -99,7 +98,7 @@ unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts (Builtins unitCekParameters = -- See Note [noinline for saving on ticks]. noinline mkMachineParameters def $ - CostModel unitCekMachineCosts (const unitCostBuiltinCostModel) + CostModel unitCekMachineCosts unitCostBuiltinCostModel defaultBuiltinsRuntimeForSemanticsVariant :: HasMeaningIn DefaultUni term diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index 92a3c5be4f3..f2f86687fce 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -30,7 +30,7 @@ data CostModel machinecosts builtincosts = CostModel { _machineCostModel :: machinecosts , _builtinCostModel :: builtincosts - } deriving stock (Eq, Show, Functor, Foldable, Traversable) + } deriving stock (Eq, Show) makeLenses ''CostModel {-| At execution time we need a 'BuiltinsRuntime' object which includes both the From a9a71bd60af2a47c42265ef7224bf743dbae4081 Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 22 Mar 2024 17:55:59 +0100 Subject: [PATCH 11/29] Provide support for multiple 'CostModel's --- plutus-benchmark/validation/bench/Common.hs | 14 +++++--- plutus-conformance/haskell/Spec.hs | 4 +-- .../budgeting-bench/Benchmarks/Nops.hs | 3 +- .../cost-model/budgeting-bench/Common.hs | 2 +- .../src/PlutusCore/Default/Builtins.hs | 2 +- .../Evaluation/Machine/ExBudgetingDefaults.hs | 8 +++-- .../Evaluation/Machine/MachineParameters.hs | 31 +++++------------ .../Machine/MachineParameters/Default.hs | 34 +++++++++++++------ .../Evaluation/Machine/Cek.hs | 16 ++++----- .../Evaluation/Machine/Cek/Internal.hs | 4 +-- .../Evaluation/Machine/CommonAPI.hs | 18 +++++----- .../Evaluation/Machine/SteppableCek.hs | 16 ++++----- .../Machine/SteppableCek/Internal.hs | 4 +-- .../test/Evaluation/Builtins/Common.hs | 2 +- .../src/PlutusLedgerApi/Common/Eval.hs | 19 ++++------- .../PlutusLedgerApi/V1/EvaluationContext.hs | 1 + .../PlutusLedgerApi/V2/EvaluationContext.hs | 1 + .../PlutusLedgerApi/V3/EvaluationContext.hs | 9 +++-- 18 files changed, 99 insertions(+), 89 deletions(-) diff --git a/plutus-benchmark/validation/bench/Common.hs b/plutus-benchmark/validation/bench/Common.hs index 5f1c2691015..345abdbb250 100644 --- a/plutus-benchmark/validation/bench/Common.hs +++ b/plutus-benchmark/validation/bench/Common.hs @@ -138,10 +138,16 @@ benchWith act = do mkEvalCtx :: EvaluationContext mkEvalCtx = case PLC.defaultCostModelParams of - -- The validation benchmarks were all created from PlutusV1 scripts - Just p -> case mkDynEvaluationContext (const PLC.DefaultFunSemanticsVariant1) p of - Right ec -> ec - Left err -> error $ show err + Just p -> + let errOrCtx = + -- The validation benchmarks were all created from PlutusV1 scripts + mkDynEvaluationContext + [PLC.DefaultFunSemanticsVariant1] + (const PLC.DefaultFunSemanticsVariant1) + p + in case errOrCtx of + Right ec -> ec + Left err -> error $ show err Nothing -> error "Couldn't get cost model params" -- | Evaluate a term as it would be evaluated using the on-chain evaluator. diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index 9c8d8156ad5..d94d4dbebe9 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/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 (const def) modelParams of + params <- case mkMachineParametersFor [def] (const def) modelParams of Left _ -> Nothing - Right p -> Just $ ($ ()) <$> p + Right p -> Just $ 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 diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs index 295eb1106b8..feeaa4cf3b6 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs @@ -120,8 +120,7 @@ nopCostModel = (ModelSixArgumentsConstantCost 600) } -nopCostParameters :: - MachineParameters CekMachineCosts (BuiltinsRuntime NopFun (CekValue DefaultUni NopFun ())) +nopCostParameters :: MachineParameters CekMachineCosts NopFun (CekValue DefaultUni NopFun ()) nopCostParameters = mkMachineParameters def $ CostModel defaultCekMachineCosts nopCostModel diff --git a/plutus-core/cost-model/budgeting-bench/Common.hs b/plutus-core/cost-model/budgeting-bench/Common.hs index 9d261c83c6e..a314102ffda 100644 --- a/plutus-core/cost-model/budgeting-bench/Common.hs +++ b/plutus-core/cost-model/budgeting-bench/Common.hs @@ -74,7 +74,7 @@ copyData = benchWith :: (Pretty fun, Typeable fun) - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue DefaultUni fun ())) + => MachineParameters CekMachineCosts fun (CekValue DefaultUni fun ()) -> String -> PlainTerm DefaultUni fun -> Benchmark diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 8b1c1bac8f9..fe5d1a1942d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1079,7 +1079,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where = DefaultFunSemanticsVariant0 | DefaultFunSemanticsVariant1 | DefaultFunSemanticsVariant2 - deriving stock (Enum, Bounded, Show) + deriving stock (Eq, Enum, Bounded, Show) -- Integers toBuiltinMeaning diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 9a2843e7412..6ed3b1fa62f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/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 @@ -79,12 +80,15 @@ 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 defaultCostModelParams = extractCostModelParams defaultCekCostModel -defaultCekParameters :: Typeable ann => MachineParameters CekMachineCosts (BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ann)) +defaultCekParameters :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) -- See Note [noinline for saving on ticks]. defaultCekParameters = noinline mkMachineParameters def defaultCekCostModel @@ -94,7 +98,7 @@ matter. Otherwise compilation for this module is slower and GHC may end up exhau ticks leading to a compilation error. -} -unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts (BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ann)) +unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) unitCekParameters = -- See Note [noinline for saving on ticks]. noinline mkMachineParameters def $ diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index f2f86687fce..d820bed04b1 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -14,8 +14,6 @@ import Control.DeepSeq import Control.Lens import GHC.Exts (inline) import GHC.Generics -import GHC.Magic (noinline) -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 @@ -37,13 +35,13 @@ makeLenses ''CostModel cost model for builtins and their denotations. This bundles one of those together with the cost model for evaluator steps. The 'term' type will be CekValue when we're using this with the CEK machine. -} -data MachineParameters machinecosts builtinsRuntime = +data MachineParameters machinecosts fun val = MachineParameters { machineCosts :: machinecosts - , builtinsRuntime :: builtinsRuntime + , builtinsRuntime :: BuiltinsRuntime fun val } - deriving stock (Generic, Functor, Foldable, Traversable) - deriving anyclass (NFData, NoThunks) + deriving stock Generic + deriving anyclass (NFData) {- Note [The CostingPart constraint in mkMachineParameters] Discharging the @CostingPart uni fun ~ builtincosts@ constraint in 'mkMachineParameters' causes GHC @@ -72,27 +70,16 @@ which makes sense: if @f@ receives all its type and term args then there's less -- See Note [Inlining meanings of builtins]. {-| This just uses 'toBuiltinsRuntime' function to convert a BuiltinCostModel to a BuiltinsRuntime. -} -mkMachineParametersFun :: +mkMachineParameters :: ( -- WARNING: do not discharge the equality constraint as that causes GHC to fail to inline the -- function at its call site, see Note [The CostingPart constraint in mkMachineParameters]. CostingPart uni fun ~ builtincosts , HasMeaningIn uni val , ToBuiltinMeaning uni fun ) - => (a -> BuiltinSemanticsVariant fun) - -> CostModel machinecosts builtincosts - -> MachineParameters machinecosts (a -> BuiltinsRuntime fun val) -mkMachineParametersFun toSemVar (CostModel mchnCosts builtinCosts) = - MachineParameters mchnCosts $ \x -> inline toBuiltinsRuntime (toSemVar x) builtinCosts -{-# INLINE mkMachineParameters #-} - -mkMachineParameters :: - ( CostingPart uni fun ~ builtincosts - , HasMeaningIn uni val - , ToBuiltinMeaning uni fun - ) => BuiltinSemanticsVariant fun -> CostModel machinecosts builtincosts - -> MachineParameters machinecosts (BuiltinsRuntime fun val) --- See Note [noinline for saving on ticks]. -mkMachineParameters semVar = fmap ($ ()) . noinline mkMachineParametersFun (const semVar) + -> MachineParameters machinecosts fun val +mkMachineParameters semVar (CostModel mchnCosts builtinCosts) = + MachineParameters mchnCosts (inline toBuiltinsRuntime semVar builtinCosts) +{-# INLINE mkMachineParameters #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 119e08a1f87..ae47e7cd452 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -1,10 +1,15 @@ +{-# 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.BuiltinCostModel import PlutusCore.Evaluation.Machine.CostModelInterface import PlutusCore.Evaluation.Machine.ExBudgetingDefaults import PlutusCore.Evaluation.Machine.MachineParameters @@ -16,10 +21,8 @@ import GHC.Exts (inline) -- | 'MachineParameters' instantiated at CEK-machine-specific types and default builtins. -- Encompasses everything we need for evaluating a UPLC program with default builtins using the CEK -- machine. -type DefaultMachineParameters a = - MachineParameters - CekMachineCosts - (a -> BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ())) +type DefaultMachineParameters = + MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) {- Note [Inlining meanings of builtins] It's vitally important to inline the 'toBuiltinMeaning' method of a set of built-in functions as @@ -58,13 +61,24 @@ 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 - => (a -> BuiltinSemanticsVariant DefaultFun) + :: forall m a. MonadError CostModelApplyError m + => [BuiltinSemanticsVariant DefaultFun] + -> (a -> BuiltinSemanticsVariant DefaultFun) -> CostModelParams - -> m (DefaultMachineParameters a) -mkMachineParametersFor toSemVar newCMP = - inline mkMachineParametersFun toSemVar <$> - applyCostModelParams defaultCekCostModel newCMP + -> m (a -> DefaultMachineParameters) +mkMachineParametersFor semVars toSemVar newCMP = + getToCostModel <&> \toCostModel x -> + let !semVar = toSemVar x + in inline mkMachineParameters semVar $ toCostModel semVar + where + getToCostModel + :: m (BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel) + getToCostModel = do + costModels <- for semVars $ \semVar -> + (,) semVar <$> applyCostModelParams (toCekCostModel semVar) newCMP + pure $ \semVar -> + fromMaybe (error "semantics variant not found") $ + lookup semVar costModels -- 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. diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs index 221b0d00aa5..ee43e07dc11 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs @@ -71,7 +71,7 @@ A wrapper around the internal runCek to debruijn input and undebruijn output. -} runCek :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Term Name uni fun ann @@ -82,7 +82,7 @@ runCek = Common.runCek runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) @@ -94,7 +94,7 @@ May throw a 'CekMachineException'. -} unsafeRunCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), cost) @@ -105,7 +105,7 @@ unsafeRunCekNoEmit = Common.unsafeRunCekNoEmit runCekDeBruijn evaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek = Common.evaluateCek runCekDeBruijn @@ -114,7 +114,7 @@ evaluateCek = Common.evaluateCek runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* evaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit = Common.evaluateCekNoEmit runCekDeBruijn @@ -124,7 +124,7 @@ evaluateCekNoEmit = Common.evaluateCekNoEmit runCekDeBruijn unsafeEvaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), [Text]) unsafeEvaluateCek = Common.unsafeEvaluateCek runCekDeBruijn @@ -133,7 +133,7 @@ unsafeEvaluateCek = Common.unsafeEvaluateCek runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* unsafeEvaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> EvaluationResult (Term Name uni fun ()) unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit runCekDeBruijn @@ -142,7 +142,7 @@ unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* readKnownCek :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) a readKnownCek = Common.readKnownCek runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index 22d7bca83fe..d310786a018 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -599,7 +599,7 @@ transferArgStack (ConsStack arg rest) c = transferArgStack rest (FrameAwaitFunVa runCekM :: forall a cost uni fun ann . ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> (forall s. GivenCekReqs uni fun ann s => CekM uni fun s a) @@ -868,7 +868,7 @@ enterComputeCek = computeCek -- | Evaluate a term using the CEK machine and keep track of costing, logging is optional. runCekDeBruijn :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> NTerm uni fun ann diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs index 3415380ae4b..fa24c961b5c 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs @@ -75,7 +75,7 @@ import Data.Text (Text) -- The type of the machine (runner function). type MachineRunner cost uni fun ann = - MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> NTerm uni fun ann @@ -98,7 +98,7 @@ A wrapper around the internal runCek to debruijn input and undebruijn output. -} runCek :: MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Term Name uni fun ann @@ -129,7 +129,7 @@ runCek runner params mode emitMode term = -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit :: MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) @@ -144,7 +144,7 @@ May throw a 'CekMachineException'. unsafeRunCekNoEmit :: ThrowableBuiltins uni fun => MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), cost) @@ -158,7 +158,7 @@ evaluateCek :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann -> EmitterMode uni fun - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek runner emitMode params = @@ -170,7 +170,7 @@ evaluateCek runner emitMode params = evaluateCekNoEmit :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit runner params = fst . runCekNoEmit runner params restrictingEnormous @@ -181,7 +181,7 @@ unsafeEvaluateCek :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann -> EmitterMode uni fun - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), [Text]) unsafeEvaluateCek runner emitTime params = @@ -193,7 +193,7 @@ unsafeEvaluateCek runner emitTime params = unsafeEvaluateCekNoEmit :: ThrowableBuiltins uni fun => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> EvaluationResult (Term Name uni fun ()) unsafeEvaluateCekNoEmit runner params = unsafeExtractEvaluationResult . evaluateCekNoEmit runner params @@ -203,7 +203,7 @@ unsafeEvaluateCekNoEmit runner params = unsafeExtractEvaluationResult . evaluate readKnownCek :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) a readKnownCek runner params = evaluateCekNoEmit runner params >=> readKnownSelf diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs index a7d9aabe14a..e81bf9ac973 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs @@ -69,7 +69,7 @@ A wrapper around the internal runCek to debruijn input and undebruijn output. -} runCek :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Term Name uni fun ann @@ -81,7 +81,7 @@ runCek = Common.runCek S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) @@ -94,7 +94,7 @@ May throw a 'CekMachineException'. -} unsafeRunCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), cost) @@ -105,7 +105,7 @@ unsafeRunCekNoEmit = Common.unsafeRunCekNoEmit S.runCekDeBruijn evaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) evaluateCek = Common.evaluateCek S.runCekDeBruijn @@ -114,7 +114,7 @@ evaluateCek = Common.evaluateCek S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* evaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) evaluateCekNoEmit = Common.evaluateCekNoEmit S.runCekDeBruijn @@ -125,7 +125,7 @@ evaluateCekNoEmit = Common.evaluateCekNoEmit S.runCekDeBruijn unsafeEvaluateCek :: ThrowableBuiltins uni fun => EmitterMode uni fun - -> MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> (EvaluationResult (Term Name uni fun ()), [Text]) unsafeEvaluateCek = Common.unsafeEvaluateCek S.runCekDeBruijn @@ -135,7 +135,7 @@ unsafeEvaluateCek = Common.unsafeEvaluateCek S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* unsafeEvaluateCekNoEmit :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> EvaluationResult (Term Name uni fun ()) unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit S.runCekDeBruijn @@ -144,7 +144,7 @@ unsafeEvaluateCekNoEmit = Common.unsafeEvaluateCekNoEmit S.runCekDeBruijn -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* readKnownCek :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> Term Name uni fun ann -> Either (CekEvaluationException Name uni fun) a readKnownCek = Common.readKnownCek S.runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index f2b076008a4..5cf72765816 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -270,7 +270,7 @@ applyEvaluate !_ val _ = -- MAYBE: runCekDeBruijn can be shared between original&debug ceks by passing a `enterComputeCek` func. runCekDeBruijn :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> NTerm uni fun ann @@ -327,7 +327,7 @@ mkCekTrans :: forall cost uni fun ann m s . ( ThrowableBuiltins uni fun , PrimMonad m, s ~ PrimState m) -- the outer monad that initializes the transition function - => MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ann)) + => MachineParameters CekMachineCosts fun (CekValue uni fun ann) -> ExBudgetMode cost uni fun -> EmitterMode uni fun -> Slippage diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs index d9fe24f8487..285059ed8f2 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Common.hs @@ -35,7 +35,7 @@ typecheckAnd , Closed uni, uni `Everywhere` ExMemoryUsage ) => BuiltinSemanticsVariant fun - -> (MachineParameters CekMachineCosts (BuiltinsRuntime fun (CekValue uni fun ())) -> + -> (MachineParameters CekMachineCosts fun (CekValue uni fun ()) -> UPLC.Term Name uni fun () -> a) -> CostingPart uni fun -> TPLC.Term TyName Name uni fun () -> m a typecheckAnd semvar action costingPart term = TPLC.runQuoteT $ do diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index fed2012fa00..f4712ad3906 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -27,7 +27,6 @@ import PlutusCore.Default import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus import PlutusCore.Evaluation.Machine.ExBudget as Plutus import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as Plutus -import PlutusCore.Evaluation.Machine.MachineParameters (MachineParameters) import PlutusCore.Evaluation.Machine.MachineParameters.Default import PlutusCore.MkPlc qualified as UPLC import PlutusCore.Pretty @@ -106,20 +105,15 @@ mkTermToEvaluate ll pv script args = do -- make sure that term is closed, i.e. well-scoped through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT -toMachineParameters - :: MajorProtocolVersion - -> EvaluationContext - -> MachineParameters - CekMachineCosts - (UPLC.BuiltinsRuntime DefaultFun (UPLC.CekValue DefaultUni DefaultFun ())) -toMachineParameters pv ctx = ($ pv) <$> machineParameters ctx +toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters +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 MajorProtocolVersion + { machineParameters :: MajorProtocolVersion -> DefaultMachineParameters } deriving stock Generic deriving anyclass (NFData, NoThunks) @@ -134,11 +128,12 @@ with the updated cost model parameters. -} mkDynEvaluationContext :: MonadError CostModelApplyError m - => (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) + => [BuiltinSemanticsVariant DefaultFun] + -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> Plutus.CostModelParams -> m EvaluationContext -mkDynEvaluationContext toSemVar newCMP = - EvaluationContext <$> mkMachineParametersFor toSemVar newCMP +mkDynEvaluationContext semVars toSemVar newCMP = + EvaluationContext <$> mkMachineParametersFor semVars toSemVar newCMP -- FIXME: remove this function assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m () diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index 518a5abbf05..0bf2054eb18 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -38,6 +38,7 @@ mkEvaluationContext = tagWithParamNames @V1.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext + [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV then DefaultFunSemanticsVariant0 else DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 653d88cc5d2..89f7e3438a9 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -38,6 +38,7 @@ mkEvaluationContext = tagWithParamNames @V2.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext + [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV then Plutus.DefaultFunSemanticsVariant0 else Plutus.DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index 24aa8b15be3..e010c50c8ff 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -32,6 +32,9 @@ a protocol update with the updated cost model parameters. mkEvaluationContext :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => [Integer] -- ^ the (updated) cost model parameters of the protocol -> m EvaluationContext -mkEvaluationContext = tagWithParamNames @V3.ParamName - >=> pure . toCostModelParams - >=> mkDynEvaluationContext (const Plutus.DefaultFunSemanticsVariant2) +mkEvaluationContext = + tagWithParamNames @V3.ParamName + >=> pure . toCostModelParams + >=> mkDynEvaluationContext + [DefaultFunSemanticsVariant2] + (const Plutus.DefaultFunSemanticsVariant2) From 3944b7f1e16524def36212f13b9abbcb955fc866 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 26 Mar 2024 10:35:58 +0100 Subject: [PATCH 12/29] Add 'SubDefaultFunSemanticsVariant' --- plutus-benchmark/validation/bench/Common.hs | 5 +-- plutus-conformance/haskell/Spec.hs | 7 ++- .../Machine/MachineParameters/Default.hs | 44 ++++++++++++------- .../src/PlutusLedgerApi/Common/Eval.hs | 10 ++--- .../PlutusLedgerApi/V1/EvaluationContext.hs | 23 ++++++++-- .../PlutusLedgerApi/V2/EvaluationContext.hs | 23 ++++++++-- .../PlutusLedgerApi/V3/EvaluationContext.hs | 17 ++++++- 7 files changed, 94 insertions(+), 35 deletions(-) diff --git a/plutus-benchmark/validation/bench/Common.hs b/plutus-benchmark/validation/bench/Common.hs index 345abdbb250..863e996d071 100644 --- a/plutus-benchmark/validation/bench/Common.hs +++ b/plutus-benchmark/validation/bench/Common.hs @@ -141,10 +141,7 @@ mkEvalCtx = Just p -> let errOrCtx = -- The validation benchmarks were all created from PlutusV1 scripts - mkDynEvaluationContext - [PLC.DefaultFunSemanticsVariant1] - (const PLC.DefaultFunSemanticsVariant1) - p + mkDynEvaluationContext (const PLC.DefaultFunSemanticsVariant1) p in case errOrCtx of Right ec -> ec Left err -> error $ show err diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index d94d4dbebe9..f62e9c4befa 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/plutus-conformance/haskell/Spec.hs @@ -1,8 +1,10 @@ -{- | Conformance tests for the Haskell implementation. -} +{-# LANGUAGE TypeApplications #-} +{- | Conformance tests for the Haskell implementation. -} module Main (main) where import PlutusConformance.Common (UplcEvaluator (..), runUplcEvalTests) +import PlutusCore.Default.Builtins as PLC import PlutusCore.Evaluation.Machine.MachineParameters.Default import PlutusPrelude (def) import UntypedPlutusCore qualified as UPLC @@ -12,7 +14,8 @@ import UntypedPlutusCore.Evaluation.Machine.Cek (CountingSt (..), counting, runC evalUplcProg :: UplcEvaluator evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do - params <- case mkMachineParametersFor [def] (const def) modelParams of + let semVarDef = def @(PLC.BuiltinSemanticsVariant PLC.DefaultFun) + params <- case mkMachineParametersFor (const semVarDef) modelParams of Left _ -> Nothing Right p -> Just $ p () -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with free variables, diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index ae47e7cd452..acfe1171df8 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} -- | 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 @@ -46,6 +48,22 @@ as we did have cases where sticking 'inline' on something that already had @INLI inlining). -} +class (Bounded semVar, Enum semVar) => SubDefaultFunSemanticsVariant semVar where + toDefaultFunSemanticsVariant :: semVar -> BuiltinSemanticsVariant DefaultFun + + memoSemVarM :: Monad m => (semVar -> m r) -> m (semVar -> r) + +instance SubDefaultFunSemanticsVariant (BuiltinSemanticsVariant DefaultFun) where + toDefaultFunSemanticsVariant = id + memoSemVarM f = do + r0 <- f DefaultFunSemanticsVariant0 + r1 <- f DefaultFunSemanticsVariant1 + r2 <- f DefaultFunSemanticsVariant2 + pure $ \case + DefaultFunSemanticsVariant0 -> r0 + DefaultFunSemanticsVariant1 -> r1 + DefaultFunSemanticsVariant2 -> r2 + -- | Produce a 'DefaultMachineParameters' given the version of the default set of built-in functions -- and a 'CostModelParams', which gets applied on top of 'defaultCekCostModel'. -- @@ -61,24 +79,20 @@ inlining). -- This function is expensive, so its result needs to be cached if it's going to be used multiple -- times. mkMachineParametersFor - :: forall m a. MonadError CostModelApplyError m - => [BuiltinSemanticsVariant DefaultFun] - -> (a -> BuiltinSemanticsVariant DefaultFun) + :: forall m a semVar. (MonadError CostModelApplyError m, SubDefaultFunSemanticsVariant semVar) + => (a -> semVar) -> CostModelParams -> m (a -> DefaultMachineParameters) -mkMachineParametersFor semVars toSemVar newCMP = +mkMachineParametersFor toSemVar newCMP = do + let getToCostModel :: m (semVar -> CostModel CekMachineCosts BuiltinCostModel) + getToCostModel = + memoSemVarM $ \semVar -> + let !semVarDefFun = toDefaultFunSemanticsVariant semVar + in applyCostModelParams (toCekCostModel semVarDefFun) newCMP getToCostModel <&> \toCostModel x -> let !semVar = toSemVar x - in inline mkMachineParameters semVar $ toCostModel semVar - where - getToCostModel - :: m (BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel) - getToCostModel = do - costModels <- for semVars $ \semVar -> - (,) semVar <$> applyCostModelParams (toCekCostModel semVar) newCMP - pure $ \semVar -> - fromMaybe (error "semantics variant not found") $ - lookup semVar costModels + !semVarDefFun = toDefaultFunSemanticsVariant semVar + in inline mkMachineParameters semVarDefFun $ toCostModel semVar -- 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. diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index f4712ad3906..ad27ddbad73 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -23,7 +23,6 @@ module PlutusLedgerApi.Common.Eval import PlutusCore import PlutusCore.Data as Plutus -import PlutusCore.Default import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus import PlutusCore.Evaluation.Machine.ExBudget as Plutus import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as Plutus @@ -127,13 +126,12 @@ IMPORTANT: The evaluation context of every Plutus version must be recreated upon with the updated cost model parameters. -} mkDynEvaluationContext - :: MonadError CostModelApplyError m - => [BuiltinSemanticsVariant DefaultFun] - -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) + :: (MonadError CostModelApplyError m, SubDefaultFunSemanticsVariant semVar) + => (MajorProtocolVersion -> semVar) -> Plutus.CostModelParams -> m EvaluationContext -mkDynEvaluationContext semVars toSemVar newCMP = - EvaluationContext <$> mkMachineParametersFor semVars toSemVar newCMP +mkDynEvaluationContext toSemVar newCMP = + EvaluationContext <$> mkMachineParametersFor toSemVar newCMP -- FIXME: remove this function assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m () diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index 0bf2054eb18..8ded9a04039 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -1,4 +1,5 @@ -- editorconfig-checker-disable +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V1.EvaluationContext ( EvaluationContext @@ -14,11 +15,28 @@ import PlutusLedgerApi.Common.Versions (conwayPV) import PlutusLedgerApi.V1.ParamName as V1 import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) +import PlutusCore.Evaluation.Machine.MachineParameters.Default (SubDefaultFunSemanticsVariant (..)) import Control.Monad import Control.Monad.Except import Control.Monad.Writer.Strict +data DefaultFunSemanticsVariant_V1 + = DefaultFunSemanticsVariant0_V1 + | DefaultFunSemanticsVariant1_V1 + deriving stock (Bounded, Enum) + +instance SubDefaultFunSemanticsVariant DefaultFunSemanticsVariant_V1 where + toDefaultFunSemanticsVariant DefaultFunSemanticsVariant0_V1 = DefaultFunSemanticsVariant0 + toDefaultFunSemanticsVariant DefaultFunSemanticsVariant1_V1 = DefaultFunSemanticsVariant1 + + memoSemVarM f = do + r0 <- f DefaultFunSemanticsVariant0_V1 + r1 <- f DefaultFunSemanticsVariant1_V1 + pure $ \case + DefaultFunSemanticsVariant0_V1 -> r0 + DefaultFunSemanticsVariant1_V1 -> r1 + {-| Build the 'EvaluationContext'. The input is a list of cost model parameters (which are integer values) passed @@ -38,7 +56,6 @@ mkEvaluationContext = tagWithParamNames @V1.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV - then DefaultFunSemanticsVariant0 - else DefaultFunSemanticsVariant1) + then DefaultFunSemanticsVariant0_V1 + else DefaultFunSemanticsVariant1_V1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 89f7e3438a9..0a217bf63e2 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -1,4 +1,5 @@ -- editorconfig-checker-disable +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V2.EvaluationContext ( EvaluationContext @@ -14,11 +15,28 @@ import PlutusLedgerApi.Common.Versions (conwayPV) import PlutusLedgerApi.V2.ParamName as V2 import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) +import PlutusCore.Evaluation.Machine.MachineParameters.Default (SubDefaultFunSemanticsVariant (..)) import Control.Monad import Control.Monad.Except import Control.Monad.Writer.Strict +data DefaultFunSemanticsVariant_V2 + = DefaultFunSemanticsVariant0_V2 + | DefaultFunSemanticsVariant1_V2 + deriving stock (Bounded, Enum) + +instance SubDefaultFunSemanticsVariant DefaultFunSemanticsVariant_V2 where + toDefaultFunSemanticsVariant DefaultFunSemanticsVariant0_V2 = DefaultFunSemanticsVariant0 + toDefaultFunSemanticsVariant DefaultFunSemanticsVariant1_V2 = DefaultFunSemanticsVariant1 + + memoSemVarM f = do + r0 <- f DefaultFunSemanticsVariant0_V2 + r1 <- f DefaultFunSemanticsVariant1_V2 + pure $ \case + DefaultFunSemanticsVariant0_V2 -> r0 + DefaultFunSemanticsVariant1_V2 -> r1 + {-| Build the 'EvaluationContext'. The input is a list of cost model parameters (which are integer values) passed @@ -38,7 +56,6 @@ mkEvaluationContext = tagWithParamNames @V2.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV - then Plutus.DefaultFunSemanticsVariant0 - else Plutus.DefaultFunSemanticsVariant1) + then DefaultFunSemanticsVariant0_V2 + else DefaultFunSemanticsVariant1_V2) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index e010c50c8ff..169b3dba67a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V3.EvaluationContext ( EvaluationContext @@ -12,11 +13,24 @@ import PlutusLedgerApi.Common import PlutusLedgerApi.V3.ParamName as V3 import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant2)) +import PlutusCore.Evaluation.Machine.MachineParameters.Default (SubDefaultFunSemanticsVariant (..)) import Control.Monad import Control.Monad.Except import Control.Monad.Writer.Strict +data DefaultFunSemanticsVariant_V3 + = DefaultFunSemanticsVariant2_V3 + deriving stock (Bounded, Enum) + +instance SubDefaultFunSemanticsVariant DefaultFunSemanticsVariant_V3 where + toDefaultFunSemanticsVariant DefaultFunSemanticsVariant2_V3 = DefaultFunSemanticsVariant2 + + memoSemVarM f = do + r2 <- f DefaultFunSemanticsVariant2_V3 + pure $ \case + DefaultFunSemanticsVariant2_V3 -> r2 + {-| Build the 'EvaluationContext'. The input is a list of cost model parameters (which are integer values) passed @@ -36,5 +50,4 @@ mkEvaluationContext = tagWithParamNames @V3.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - [DefaultFunSemanticsVariant2] - (const Plutus.DefaultFunSemanticsVariant2) + (const DefaultFunSemanticsVariant2_V3) From 3134e888ba87e7088b666f7ffd2b8fc27d92a8c2 Mon Sep 17 00:00:00 2001 From: effectfully Date: Wed, 27 Mar 2024 16:10:52 +0100 Subject: [PATCH 13/29] Fix the arbitrary evaluation nonsense in 'nofib' --- .../common/PlutusBenchmark/Common.hs | 37 ++++++++++++++++++- plutus-benchmark/nofib/bench/BenchCek.hs | 18 +++++++-- plutus-benchmark/nofib/bench/Shared.hs | 12 ++++-- plutus-benchmark/plutus-benchmark.cabal | 4 +- plutus-benchmark/validation/bench/Common.hs | 37 +------------------ 5 files changed, 62 insertions(+), 46 deletions(-) diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 8efa174e413..047dac7640c 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -16,6 +16,8 @@ module PlutusBenchmark.Common , unsafeRunTermCek , runTermCek , cekResultMatchesHaskellValue + , mkEvalCtx + , evaluateCekLikeInProd , benchTermAgdaCek , benchProgramAgdaCek , TestSize (..) @@ -29,14 +31,19 @@ where import Paths_plutus_benchmark as Export import PlutusBenchmark.ProtocolParameters as PP +import PlutusLedgerApi.Common qualified as LedgerApi + +import PlutusTx qualified as Tx + import PlutusCore qualified as PLC import PlutusCore.Default import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) -import PlutusTx qualified as Tx + import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek as Cek +import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC import MAlonzo.Code.Evaluator.Term (runUAgda) @@ -156,6 +163,34 @@ cekResultMatchesHaskellValue cekResultMatchesHaskellValue term matches value = (unsafeRunTermCek term) `matches` (unsafeRunTermCek $ haskellValueToTerm value) +-- | Create the evaluation context for the benchmarks. This doesn't exactly match how it's done +-- on-chain, but that's okay because the evaluation context is cached by the ledger, so we're +-- deliberately not including it in the benchmarks. +mkEvalCtx :: LedgerApi.EvaluationContext +mkEvalCtx = + case PLC.defaultCostModelParams of + Just p -> + let errOrCtx = + -- The validation benchmarks were all created from PlutusV1 scripts + LedgerApi.mkDynEvaluationContext (const DefaultFunSemanticsVariant1) p + in case errOrCtx of + Right ec -> ec + Left err -> error $ show err + Nothing -> error "Couldn't get cost model params" + +-- | Evaluate a term as it would be evaluated using the on-chain evaluator. +evaluateCekLikeInProd + :: LedgerApi.EvaluationContext + -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + -> Either + (UPLC.CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) +evaluateCekLikeInProd evalCtx term = do + let (getRes, _, _) = + let pv = LedgerApi.ledgerLanguageIntroducedIn LedgerApi.PlutusV1 + -- The validation benchmarks were all created from PlutusV1 scripts + in LedgerApi.evaluateTerm UPLC.restrictingEnormous pv LedgerApi.Quiet evalCtx term + getRes ---------------- Run a term or program using the plutus-metatheory CEK evaluator ---------------- diff --git a/plutus-benchmark/nofib/bench/BenchCek.hs b/plutus-benchmark/nofib/bench/BenchCek.hs index 73aaa4a37c7..dff8e64c9ad 100644 --- a/plutus-benchmark/nofib/bench/BenchCek.hs +++ b/plutus-benchmark/nofib/bench/BenchCek.hs @@ -1,8 +1,20 @@ +{-# LANGUAGE BangPatterns #-} + {- | Plutus benchmarks for the CEK machine based on some nofib examples. -} module Main where -import PlutusBenchmark.Common (benchTermCek) -import Shared (benchWith) +import Shared (benchWith, evaluateCekLikeInProd, mkEvalCtx) + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Criterion (whnf) main :: IO () -main = benchWith benchTermCek +main = do + evalCtx <- evaluate $ force mkEvalCtx + let mkCekBM term = + -- `force` to try to ensure that deserialiation is not included in benchmarking time. + let !benchTerm = force term + eval = either (error . show) (\_ -> ()) . evaluateCekLikeInProd evalCtx + in whnf eval benchTerm + benchWith mkCekBM diff --git a/plutus-benchmark/nofib/bench/Shared.hs b/plutus-benchmark/nofib/bench/Shared.hs index 35e409e8cd6..99b3015cc54 100644 --- a/plutus-benchmark/nofib/bench/Shared.hs +++ b/plutus-benchmark/nofib/bench/Shared.hs @@ -1,8 +1,12 @@ {- | Shared code for benchmarking Plutus and Haskell versions of the Plutus nofib examples -} -module Shared (benchWith, mkBenchMarks) -where - -import PlutusBenchmark.Common (Term, getConfig) +module Shared ( + benchWith + , mkBenchMarks + , mkEvalCtx + , evaluateCekLikeInProd + ) where + +import PlutusBenchmark.Common (Term, evaluateCekLikeInProd, getConfig, mkEvalCtx) import PlutusBenchmark.NoFib.Clausify qualified as Clausify import PlutusBenchmark.NoFib.Knights qualified as Knights diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 45482f90725..c6291bed1c2 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -79,6 +79,7 @@ library plutus-benchmark-common , filepath , flat ^>=0.6 , plutus-core ^>=1.24 + , plutus-ledger-api ^>=1.24 , plutus-metatheory , plutus-tx ^>=1.24 , tasty @@ -141,6 +142,7 @@ benchmark nofib build-depends: , base >=4.9 && <5 , criterion >=1.5.9.0 + , deepseq , nofib-internal , plutus-benchmark-common @@ -262,7 +264,6 @@ benchmark validation , optparse-applicative , plutus-benchmark-common , plutus-core ^>=1.24 - , plutus-ledger-api ^>=1.24 ---------------- validation-decode ---------------- @@ -567,7 +568,6 @@ benchmark validation-agda-cek , optparse-applicative , plutus-benchmark-common , plutus-core ^>=1.24 - , plutus-ledger-api ^>=1.24 benchmark nofib-agda-cek import: lang, ghc-version-support diff --git a/plutus-benchmark/validation/bench/Common.hs b/plutus-benchmark/validation/bench/Common.hs index 863e996d071..3b1cff773a4 100644 --- a/plutus-benchmark/validation/bench/Common.hs +++ b/plutus-benchmark/validation/bench/Common.hs @@ -9,19 +9,12 @@ module Common ( , Term ) where -import PlutusBenchmark.Common (getConfig, getDataDir) +import PlutusBenchmark.Common (evaluateCekLikeInProd, getConfig, getDataDir, mkEvalCtx) import PlutusBenchmark.NaturalSort -import PlutusCore qualified as PLC import PlutusCore.Builtin qualified as PLC import PlutusCore.Data qualified as PLC -import PlutusCore.Default qualified as PLC (BuiltinSemanticsVariant (DefaultFunSemanticsVariant1)) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC -import PlutusLedgerApi.Common (PlutusLedgerLanguage (PlutusV1), evaluateTerm, - ledgerLanguageIntroducedIn, mkDynEvaluationContext) -import PlutusLedgerApi.V1 (EvaluationContext, VerboseMode (..)) import UntypedPlutusCore qualified as UPLC -import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC import Criterion.Main import Criterion.Main.Options (Mode, parseWith) @@ -132,34 +125,6 @@ benchWith act = do env (BS.readFile $ dir file) $ \(~scriptBS) -> bench (dropExtension file) $ act file scriptBS --- | Create the evaluation context for the benchmarks. This doesn't exactly match how it's done --- on-chain, but that's okay because the evaluation context is cached by the ledger, so we're --- deliberately not including it in the benchmarks. -mkEvalCtx :: EvaluationContext -mkEvalCtx = - case PLC.defaultCostModelParams of - Just p -> - let errOrCtx = - -- The validation benchmarks were all created from PlutusV1 scripts - mkDynEvaluationContext (const PLC.DefaultFunSemanticsVariant1) p - in case errOrCtx of - Right ec -> ec - Left err -> error $ show err - Nothing -> error "Couldn't get cost model params" - --- | Evaluate a term as it would be evaluated using the on-chain evaluator. -evaluateCekLikeInProd - :: EvaluationContext - -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () - -> Either - (UPLC.CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) - (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) -evaluateCekLikeInProd evalCtx term = do - let (getRes, _, _) = - -- The validation benchmarks were all created from PlutusV1 scripts - evaluateTerm UPLC.restrictingEnormous (ledgerLanguageIntroducedIn PlutusV1) Quiet evalCtx term - getRes - type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () -- | If the term is an application of something to some arguments, peel off From 86a176d25bc80a5f20f4c7838abc55ae463c76cf Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 1 Apr 2024 12:17:52 +0200 Subject: [PATCH 14/29] Revert "Add 'SubDefaultFunSemanticsVariant'" This reverts commit 3944b7f1e16524def36212f13b9abbcb955fc866. --- .../common/PlutusBenchmark/Common.hs | 5 ++- plutus-conformance/haskell/Spec.hs | 7 +-- .../Machine/MachineParameters/Default.hs | 44 +++++++------------ .../src/PlutusLedgerApi/Common/Eval.hs | 10 +++-- .../PlutusLedgerApi/V1/EvaluationContext.hs | 23 ++-------- .../PlutusLedgerApi/V2/EvaluationContext.hs | 23 ++-------- .../PlutusLedgerApi/V3/EvaluationContext.hs | 17 +------ 7 files changed, 35 insertions(+), 94 deletions(-) diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 047dac7640c..08cb4a5b84d 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -172,7 +172,10 @@ mkEvalCtx = Just p -> let errOrCtx = -- The validation benchmarks were all created from PlutusV1 scripts - LedgerApi.mkDynEvaluationContext (const DefaultFunSemanticsVariant1) p + LedgerApi.mkDynEvaluationContext + [DefaultFunSemanticsVariant1] + (const DefaultFunSemanticsVariant1) + p in case errOrCtx of Right ec -> ec Left err -> error $ show err diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index f62e9c4befa..d94d4dbebe9 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/plutus-conformance/haskell/Spec.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE TypeApplications #-} - {- | Conformance tests for the Haskell implementation. -} + module Main (main) where import PlutusConformance.Common (UplcEvaluator (..), runUplcEvalTests) -import PlutusCore.Default.Builtins as PLC import PlutusCore.Evaluation.Machine.MachineParameters.Default import PlutusPrelude (def) import UntypedPlutusCore qualified as UPLC @@ -14,8 +12,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek (CountingSt (..), counting, runC evalUplcProg :: UplcEvaluator evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do - let semVarDef = def @(PLC.BuiltinSemanticsVariant PLC.DefaultFun) - params <- case mkMachineParametersFor (const semVarDef) modelParams of + params <- case mkMachineParametersFor [def] (const def) modelParams of Left _ -> Nothing Right p -> Just $ p () -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with free variables, diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index acfe1171df8..ae47e7cd452 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# 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 @@ -48,22 +46,6 @@ as we did have cases where sticking 'inline' on something that already had @INLI inlining). -} -class (Bounded semVar, Enum semVar) => SubDefaultFunSemanticsVariant semVar where - toDefaultFunSemanticsVariant :: semVar -> BuiltinSemanticsVariant DefaultFun - - memoSemVarM :: Monad m => (semVar -> m r) -> m (semVar -> r) - -instance SubDefaultFunSemanticsVariant (BuiltinSemanticsVariant DefaultFun) where - toDefaultFunSemanticsVariant = id - memoSemVarM f = do - r0 <- f DefaultFunSemanticsVariant0 - r1 <- f DefaultFunSemanticsVariant1 - r2 <- f DefaultFunSemanticsVariant2 - pure $ \case - DefaultFunSemanticsVariant0 -> r0 - DefaultFunSemanticsVariant1 -> r1 - DefaultFunSemanticsVariant2 -> r2 - -- | Produce a 'DefaultMachineParameters' given the version of the default set of built-in functions -- and a 'CostModelParams', which gets applied on top of 'defaultCekCostModel'. -- @@ -79,20 +61,24 @@ instance SubDefaultFunSemanticsVariant (BuiltinSemanticsVariant DefaultFun) wher -- This function is expensive, so its result needs to be cached if it's going to be used multiple -- times. mkMachineParametersFor - :: forall m a semVar. (MonadError CostModelApplyError m, SubDefaultFunSemanticsVariant semVar) - => (a -> semVar) + :: forall m a. MonadError CostModelApplyError m + => [BuiltinSemanticsVariant DefaultFun] + -> (a -> BuiltinSemanticsVariant DefaultFun) -> CostModelParams -> m (a -> DefaultMachineParameters) -mkMachineParametersFor toSemVar newCMP = do - let getToCostModel :: m (semVar -> CostModel CekMachineCosts BuiltinCostModel) - getToCostModel = - memoSemVarM $ \semVar -> - let !semVarDefFun = toDefaultFunSemanticsVariant semVar - in applyCostModelParams (toCekCostModel semVarDefFun) newCMP +mkMachineParametersFor semVars toSemVar newCMP = getToCostModel <&> \toCostModel x -> let !semVar = toSemVar x - !semVarDefFun = toDefaultFunSemanticsVariant semVar - in inline mkMachineParameters semVarDefFun $ toCostModel semVar + in inline mkMachineParameters semVar $ toCostModel semVar + where + getToCostModel + :: m (BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel) + getToCostModel = do + costModels <- for semVars $ \semVar -> + (,) semVar <$> applyCostModelParams (toCekCostModel semVar) newCMP + pure $ \semVar -> + fromMaybe (error "semantics variant not found") $ + lookup semVar costModels -- 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. diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index ad27ddbad73..f4712ad3906 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -23,6 +23,7 @@ module PlutusLedgerApi.Common.Eval import PlutusCore import PlutusCore.Data as Plutus +import PlutusCore.Default import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus import PlutusCore.Evaluation.Machine.ExBudget as Plutus import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as Plutus @@ -126,12 +127,13 @@ IMPORTANT: The evaluation context of every Plutus version must be recreated upon with the updated cost model parameters. -} mkDynEvaluationContext - :: (MonadError CostModelApplyError m, SubDefaultFunSemanticsVariant semVar) - => (MajorProtocolVersion -> semVar) + :: MonadError CostModelApplyError m + => [BuiltinSemanticsVariant DefaultFun] + -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> Plutus.CostModelParams -> m EvaluationContext -mkDynEvaluationContext toSemVar newCMP = - EvaluationContext <$> mkMachineParametersFor toSemVar newCMP +mkDynEvaluationContext semVars toSemVar newCMP = + EvaluationContext <$> mkMachineParametersFor semVars toSemVar newCMP -- FIXME: remove this function assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m () diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index 8ded9a04039..0bf2054eb18 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -1,5 +1,4 @@ -- editorconfig-checker-disable -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V1.EvaluationContext ( EvaluationContext @@ -15,28 +14,11 @@ import PlutusLedgerApi.Common.Versions (conwayPV) import PlutusLedgerApi.V1.ParamName as V1 import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) -import PlutusCore.Evaluation.Machine.MachineParameters.Default (SubDefaultFunSemanticsVariant (..)) import Control.Monad import Control.Monad.Except import Control.Monad.Writer.Strict -data DefaultFunSemanticsVariant_V1 - = DefaultFunSemanticsVariant0_V1 - | DefaultFunSemanticsVariant1_V1 - deriving stock (Bounded, Enum) - -instance SubDefaultFunSemanticsVariant DefaultFunSemanticsVariant_V1 where - toDefaultFunSemanticsVariant DefaultFunSemanticsVariant0_V1 = DefaultFunSemanticsVariant0 - toDefaultFunSemanticsVariant DefaultFunSemanticsVariant1_V1 = DefaultFunSemanticsVariant1 - - memoSemVarM f = do - r0 <- f DefaultFunSemanticsVariant0_V1 - r1 <- f DefaultFunSemanticsVariant1_V1 - pure $ \case - DefaultFunSemanticsVariant0_V1 -> r0 - DefaultFunSemanticsVariant1_V1 -> r1 - {-| Build the 'EvaluationContext'. The input is a list of cost model parameters (which are integer values) passed @@ -56,6 +38,7 @@ mkEvaluationContext = tagWithParamNames @V1.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext + [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV - then DefaultFunSemanticsVariant0_V1 - else DefaultFunSemanticsVariant1_V1) + then DefaultFunSemanticsVariant0 + else DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 0a217bf63e2..89f7e3438a9 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -1,5 +1,4 @@ -- editorconfig-checker-disable -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V2.EvaluationContext ( EvaluationContext @@ -15,28 +14,11 @@ import PlutusLedgerApi.Common.Versions (conwayPV) import PlutusLedgerApi.V2.ParamName as V2 import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) -import PlutusCore.Evaluation.Machine.MachineParameters.Default (SubDefaultFunSemanticsVariant (..)) import Control.Monad import Control.Monad.Except import Control.Monad.Writer.Strict -data DefaultFunSemanticsVariant_V2 - = DefaultFunSemanticsVariant0_V2 - | DefaultFunSemanticsVariant1_V2 - deriving stock (Bounded, Enum) - -instance SubDefaultFunSemanticsVariant DefaultFunSemanticsVariant_V2 where - toDefaultFunSemanticsVariant DefaultFunSemanticsVariant0_V2 = DefaultFunSemanticsVariant0 - toDefaultFunSemanticsVariant DefaultFunSemanticsVariant1_V2 = DefaultFunSemanticsVariant1 - - memoSemVarM f = do - r0 <- f DefaultFunSemanticsVariant0_V2 - r1 <- f DefaultFunSemanticsVariant1_V2 - pure $ \case - DefaultFunSemanticsVariant0_V2 -> r0 - DefaultFunSemanticsVariant1_V2 -> r1 - {-| Build the 'EvaluationContext'. The input is a list of cost model parameters (which are integer values) passed @@ -56,6 +38,7 @@ mkEvaluationContext = tagWithParamNames @V2.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext + [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV - then DefaultFunSemanticsVariant0_V2 - else DefaultFunSemanticsVariant1_V2) + then Plutus.DefaultFunSemanticsVariant0 + else Plutus.DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index 169b3dba67a..e010c50c8ff 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeApplications #-} module PlutusLedgerApi.V3.EvaluationContext ( EvaluationContext @@ -13,24 +12,11 @@ import PlutusLedgerApi.Common import PlutusLedgerApi.V3.ParamName as V3 import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant2)) -import PlutusCore.Evaluation.Machine.MachineParameters.Default (SubDefaultFunSemanticsVariant (..)) import Control.Monad import Control.Monad.Except import Control.Monad.Writer.Strict -data DefaultFunSemanticsVariant_V3 - = DefaultFunSemanticsVariant2_V3 - deriving stock (Bounded, Enum) - -instance SubDefaultFunSemanticsVariant DefaultFunSemanticsVariant_V3 where - toDefaultFunSemanticsVariant DefaultFunSemanticsVariant2_V3 = DefaultFunSemanticsVariant2 - - memoSemVarM f = do - r2 <- f DefaultFunSemanticsVariant2_V3 - pure $ \case - DefaultFunSemanticsVariant2_V3 -> r2 - {-| Build the 'EvaluationContext'. The input is a list of cost model parameters (which are integer values) passed @@ -50,4 +36,5 @@ mkEvaluationContext = tagWithParamNames @V3.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - (const DefaultFunSemanticsVariant2_V3) + [DefaultFunSemanticsVariant2] + (const Plutus.DefaultFunSemanticsVariant2) From d2b57a614ca61c6b93e7d2b495a6879cea983b7d Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 4 Apr 2024 19:03:00 +0200 Subject: [PATCH 15/29] Revert "Fix the arbitrary evaluation nonsense in 'nofib'" This reverts commit 3134e888ba87e7088b666f7ffd2b8fc27d92a8c2. --- .../common/PlutusBenchmark/Common.hs | 9 +---- plutus-benchmark/nofib/bench/BenchCek.hs | 18 ++------- plutus-benchmark/nofib/bench/Shared.hs | 12 ++---- plutus-benchmark/plutus-benchmark.cabal | 4 +- plutus-benchmark/validation/bench/Common.hs | 37 ++++++++++++++++++- 5 files changed, 46 insertions(+), 34 deletions(-) diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 08cb4a5b84d..73ad825951a 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -16,8 +16,6 @@ module PlutusBenchmark.Common , unsafeRunTermCek , runTermCek , cekResultMatchesHaskellValue - , mkEvalCtx - , evaluateCekLikeInProd , benchTermAgdaCek , benchProgramAgdaCek , TestSize (..) @@ -31,19 +29,14 @@ where import Paths_plutus_benchmark as Export import PlutusBenchmark.ProtocolParameters as PP -import PlutusLedgerApi.Common qualified as LedgerApi - -import PlutusTx qualified as Tx - import PlutusCore qualified as PLC import PlutusCore.Default import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) - +import PlutusTx qualified as Tx import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek as Cek -import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC import MAlonzo.Code.Evaluator.Term (runUAgda) diff --git a/plutus-benchmark/nofib/bench/BenchCek.hs b/plutus-benchmark/nofib/bench/BenchCek.hs index dff8e64c9ad..73aaa4a37c7 100644 --- a/plutus-benchmark/nofib/bench/BenchCek.hs +++ b/plutus-benchmark/nofib/bench/BenchCek.hs @@ -1,20 +1,8 @@ -{-# LANGUAGE BangPatterns #-} - {- | Plutus benchmarks for the CEK machine based on some nofib examples. -} module Main where -import Shared (benchWith, evaluateCekLikeInProd, mkEvalCtx) - -import Control.DeepSeq (force) -import Control.Exception (evaluate) -import Criterion (whnf) +import PlutusBenchmark.Common (benchTermCek) +import Shared (benchWith) main :: IO () -main = do - evalCtx <- evaluate $ force mkEvalCtx - let mkCekBM term = - -- `force` to try to ensure that deserialiation is not included in benchmarking time. - let !benchTerm = force term - eval = either (error . show) (\_ -> ()) . evaluateCekLikeInProd evalCtx - in whnf eval benchTerm - benchWith mkCekBM +main = benchWith benchTermCek diff --git a/plutus-benchmark/nofib/bench/Shared.hs b/plutus-benchmark/nofib/bench/Shared.hs index 99b3015cc54..35e409e8cd6 100644 --- a/plutus-benchmark/nofib/bench/Shared.hs +++ b/plutus-benchmark/nofib/bench/Shared.hs @@ -1,12 +1,8 @@ {- | Shared code for benchmarking Plutus and Haskell versions of the Plutus nofib examples -} -module Shared ( - benchWith - , mkBenchMarks - , mkEvalCtx - , evaluateCekLikeInProd - ) where - -import PlutusBenchmark.Common (Term, evaluateCekLikeInProd, getConfig, mkEvalCtx) +module Shared (benchWith, mkBenchMarks) +where + +import PlutusBenchmark.Common (Term, getConfig) import PlutusBenchmark.NoFib.Clausify qualified as Clausify import PlutusBenchmark.NoFib.Knights qualified as Knights diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index c6291bed1c2..45482f90725 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -79,7 +79,6 @@ library plutus-benchmark-common , filepath , flat ^>=0.6 , plutus-core ^>=1.24 - , plutus-ledger-api ^>=1.24 , plutus-metatheory , plutus-tx ^>=1.24 , tasty @@ -142,7 +141,6 @@ benchmark nofib build-depends: , base >=4.9 && <5 , criterion >=1.5.9.0 - , deepseq , nofib-internal , plutus-benchmark-common @@ -264,6 +262,7 @@ benchmark validation , optparse-applicative , plutus-benchmark-common , plutus-core ^>=1.24 + , plutus-ledger-api ^>=1.24 ---------------- validation-decode ---------------- @@ -568,6 +567,7 @@ benchmark validation-agda-cek , optparse-applicative , plutus-benchmark-common , plutus-core ^>=1.24 + , plutus-ledger-api ^>=1.24 benchmark nofib-agda-cek import: lang, ghc-version-support diff --git a/plutus-benchmark/validation/bench/Common.hs b/plutus-benchmark/validation/bench/Common.hs index 3b1cff773a4..863e996d071 100644 --- a/plutus-benchmark/validation/bench/Common.hs +++ b/plutus-benchmark/validation/bench/Common.hs @@ -9,12 +9,19 @@ module Common ( , Term ) where -import PlutusBenchmark.Common (evaluateCekLikeInProd, getConfig, getDataDir, mkEvalCtx) +import PlutusBenchmark.Common (getConfig, getDataDir) import PlutusBenchmark.NaturalSort +import PlutusCore qualified as PLC import PlutusCore.Builtin qualified as PLC import PlutusCore.Data qualified as PLC +import PlutusCore.Default qualified as PLC (BuiltinSemanticsVariant (DefaultFunSemanticsVariant1)) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC +import PlutusLedgerApi.Common (PlutusLedgerLanguage (PlutusV1), evaluateTerm, + ledgerLanguageIntroducedIn, mkDynEvaluationContext) +import PlutusLedgerApi.V1 (EvaluationContext, VerboseMode (..)) import UntypedPlutusCore qualified as UPLC +import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC import Criterion.Main import Criterion.Main.Options (Mode, parseWith) @@ -125,6 +132,34 @@ benchWith act = do env (BS.readFile $ dir file) $ \(~scriptBS) -> bench (dropExtension file) $ act file scriptBS +-- | Create the evaluation context for the benchmarks. This doesn't exactly match how it's done +-- on-chain, but that's okay because the evaluation context is cached by the ledger, so we're +-- deliberately not including it in the benchmarks. +mkEvalCtx :: EvaluationContext +mkEvalCtx = + case PLC.defaultCostModelParams of + Just p -> + let errOrCtx = + -- The validation benchmarks were all created from PlutusV1 scripts + mkDynEvaluationContext (const PLC.DefaultFunSemanticsVariant1) p + in case errOrCtx of + Right ec -> ec + Left err -> error $ show err + Nothing -> error "Couldn't get cost model params" + +-- | Evaluate a term as it would be evaluated using the on-chain evaluator. +evaluateCekLikeInProd + :: EvaluationContext + -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + -> Either + (UPLC.CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) +evaluateCekLikeInProd evalCtx term = do + let (getRes, _, _) = + -- The validation benchmarks were all created from PlutusV1 scripts + evaluateTerm UPLC.restrictingEnormous (ledgerLanguageIntroducedIn PlutusV1) Quiet evalCtx term + getRes + type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () -- | If the term is an application of something to some arguments, peel off From 12679c7625007a1436dcdc17952a47bd4edb08d5 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 9 Apr 2024 23:36:41 +0200 Subject: [PATCH 16/29] Put 'mkMachineParameters' inside the loop --- .../Evaluation/Machine/MachineParameters/Default.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index ae47e7cd452..902956434c2 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -9,7 +9,6 @@ import PlutusPrelude import PlutusCore.Builtin import PlutusCore.Default -import PlutusCore.Evaluation.Machine.BuiltinCostModel import PlutusCore.Evaluation.Machine.CostModelInterface import PlutusCore.Evaluation.Machine.ExBudgetingDefaults import PlutusCore.Evaluation.Machine.MachineParameters @@ -67,15 +66,14 @@ mkMachineParametersFor -> CostModelParams -> m (a -> DefaultMachineParameters) mkMachineParametersFor semVars toSemVar newCMP = - getToCostModel <&> \toCostModel x -> - let !semVar = toSemVar x - in inline mkMachineParameters semVar $ toCostModel semVar + getToCostModel <&> \toMachineParameters -> toMachineParameters . toSemVar where getToCostModel - :: m (BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel) + :: m (BuiltinSemanticsVariant DefaultFun -> DefaultMachineParameters) getToCostModel = do costModels <- for semVars $ \semVar -> - (,) semVar <$> applyCostModelParams (toCekCostModel semVar) newCMP + (,) semVar . inline mkMachineParameters semVar <$> + applyCostModelParams (toCekCostModel semVar) newCMP pure $ \semVar -> fromMaybe (error "semantics variant not found") $ lookup semVar costModels From 6151af8395104a85f9431485dd708bb96c02cd50 Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 11 Apr 2024 13:19:26 +0200 Subject: [PATCH 17/29] Make errors explicit --- .../common/PlutusBenchmark/Common.hs | 1 + plutus-conformance/haskell/Spec.hs | 2 +- .../Machine/MachineParameters/Default.hs | 19 ++++++------------- .../src/PlutusLedgerApi/Common/Eval.hs | 12 +++++++++--- .../PlutusLedgerApi/V1/EvaluationContext.hs | 1 + .../PlutusLedgerApi/V2/EvaluationContext.hs | 1 + .../PlutusLedgerApi/V3/EvaluationContext.hs | 1 + 7 files changed, 20 insertions(+), 17 deletions(-) diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index ab632c2127b..80e672aa7bb 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -170,6 +170,7 @@ mkEvalCtx = let errOrCtx = -- The validation benchmarks were all created from PlutusV1 scripts LedgerApi.mkDynEvaluationContext + "PlutusV1" [DefaultFunSemanticsVariant1] (const DefaultFunSemanticsVariant1) p diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index d94d4dbebe9..9296b50ed12 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/plutus-conformance/haskell/Spec.hs @@ -12,7 +12,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek (CountingSt (..), counting, runC evalUplcProg :: UplcEvaluator evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do - params <- case mkMachineParametersFor [def] (const def) modelParams of + params <- case mkMachineParametersFor "PlutusVdef" [def] (const def) modelParams of Left _ -> Nothing Right p -> Just $ p () -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with free variables, diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 902956434c2..d80f8ccbcec 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -64,19 +64,12 @@ mkMachineParametersFor => [BuiltinSemanticsVariant DefaultFun] -> (a -> BuiltinSemanticsVariant DefaultFun) -> CostModelParams - -> m (a -> DefaultMachineParameters) -mkMachineParametersFor semVars toSemVar newCMP = - getToCostModel <&> \toMachineParameters -> toMachineParameters . toSemVar - where - getToCostModel - :: m (BuiltinSemanticsVariant DefaultFun -> DefaultMachineParameters) - getToCostModel = do - costModels <- for semVars $ \semVar -> - (,) semVar . inline mkMachineParameters semVar <$> - applyCostModelParams (toCekCostModel semVar) newCMP - pure $ \semVar -> - fromMaybe (error "semantics variant not found") $ - lookup semVar costModels + -> 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. diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index f4712ad3906..16ae8ad673d 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -128,12 +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 semVars toSemVar newCMP = - EvaluationContext <$> mkMachineParametersFor semVars toSemVar 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 () diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index 0bf2054eb18..8b047a1bd7c 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -38,6 +38,7 @@ mkEvaluationContext = tagWithParamNames @V1.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext + "PlutusV1" [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV then DefaultFunSemanticsVariant0 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 89f7e3438a9..d3d51a60086 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -38,6 +38,7 @@ mkEvaluationContext = tagWithParamNames @V2.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext + "PlutusV2" [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV then Plutus.DefaultFunSemanticsVariant0 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index e010c50c8ff..ee2bd5657ea 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -36,5 +36,6 @@ mkEvaluationContext = tagWithParamNames @V3.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext + "PlutusV3" [DefaultFunSemanticsVariant2] (const Plutus.DefaultFunSemanticsVariant2) From 20e2677a86311f0355e2e6c7f4be3a63b71868c0 Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 11 Apr 2024 15:19:50 +0200 Subject: [PATCH 18/29] Add a call to 'lazy' in 'toBuiltinsRuntime' out of paranoia --- plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index e84ef9cbec9..c90849436b8 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -398,5 +398,5 @@ toBuiltinsRuntime -> cost -> BuiltinsRuntime fun val toBuiltinsRuntime semvar cost = - BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar + lazy . BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar {-# INLINE toBuiltinsRuntime #-} From e543b2854910d6196c74890318b940c80533bcbe Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 11 Apr 2024 16:08:08 +0200 Subject: [PATCH 19/29] Fix 'haskell-conformance' --- plutus-conformance/haskell/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index 9296b50ed12..b8d22291b7c 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/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 "PlutusVdef" [def] (const 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 From 12bbcc18227723f1285aa3d95f2990a1cd87776e Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 15 Apr 2024 16:19:00 +0200 Subject: [PATCH 20/29] Comments --- .../plutus-core/src/PlutusCore/Builtin/Meaning.hs | 10 ++++++++++ .../PlutusCore/Evaluation/Machine/MachineParameters.hs | 10 ++++++++-- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index c90849436b8..a8838df74fd 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -398,5 +398,15 @@ toBuiltinsRuntime -> cost -> BuiltinsRuntime fun val toBuiltinsRuntime semvar cost = + -- 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 #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index d820bed04b1..f830cf1a24a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -14,6 +14,7 @@ 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 @@ -43,6 +44,11 @@ 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 @@ -80,6 +86,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 #-} From 4d3ddb01ba08963607f172d9429cae1b293e2fc2 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 15 Apr 2024 22:08:34 +0200 Subject: [PATCH 21/29] Use a list instead of a function --- .../common/PlutusBenchmark/Common.hs | 2 +- plutus-conformance/haskell/Spec.hs | 6 +++--- .../src/PlutusCore/Default/Builtins.hs | 4 +++- .../Machine/MachineParameters/Default.hs | 12 +++++------ .../src/PlutusLedgerApi/Common/Eval.hs | 21 ++++++++++--------- .../src/PlutusLedgerApi/Common/Versions.hs | 6 +++++- .../PlutusLedgerApi/V1/EvaluationContext.hs | 2 +- .../PlutusLedgerApi/V2/EvaluationContext.hs | 2 +- .../PlutusLedgerApi/V3/EvaluationContext.hs | 2 +- 9 files changed, 32 insertions(+), 25 deletions(-) diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 8a3ad3cb2e7..0f55a22e9f4 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -166,7 +166,7 @@ mkEvalCtx = let errOrCtx = -- The validation benchmarks were all created from PlutusV1 scripts LedgerApi.mkDynEvaluationContext - "PlutusV1" + LedgerApi.PlutusV1 [DefaultFunSemanticsVariant1] (const DefaultFunSemanticsVariant1) p diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index b8d22291b7c..a544b7ef95b 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/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] (const def) modelParams of - Left _ -> Nothing - Right p -> 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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 744a590bf69..33c46234256 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/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]. @@ -1079,7 +1080,8 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where = DefaultFunSemanticsVariant0 | DefaultFunSemanticsVariant1 | DefaultFunSemanticsVariant2 - deriving stock (Eq, Enum, Bounded, Show) + deriving stock (Eq, Enum, Bounded, Show, Generic) + deriving anyclass (NFData, NoThunks) -- Integers toBuiltinMeaning diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index d80f8ccbcec..b086fd07a67 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -14,6 +14,7 @@ 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) @@ -60,16 +61,15 @@ inlining). -- This function is expensive, so its result needs to be cached if it's going to be used multiple -- times. mkMachineParametersFor - :: forall m a. MonadError CostModelApplyError m + :: forall m. MonadError CostModelApplyError m => [BuiltinSemanticsVariant DefaultFun] - -> (a -> BuiltinSemanticsVariant DefaultFun) -> CostModelParams - -> m (a -> Maybe DefaultMachineParameters) -mkMachineParametersFor semVars toSemVar newCMP = do - semVarAndMachineParametersCache <- for semVars $ \semVar -> + -> m [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)] +mkMachineParametersFor semVars newCMP = do + res <- for semVars $ \semVar -> (,) semVar . inline mkMachineParameters semVar <$> applyCostModelParams (toCekCostModel semVar) newCMP - pure $ \x -> lookup (toSemVar x) semVarAndMachineParametersCache + 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. diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 16ae8ad673d..2498811dcdd 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -106,14 +106,20 @@ mkTermToEvaluate ll pv script args = do through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters -toMachineParameters pv ctx = machineParameters ctx pv +toMachineParameters pv (EvaluationContext lv toSemVar machParsList) = + case lookup (toSemVar pv) machParsList of + Nothing -> error $ Prelude.concat + ["Internal error: ", show lv, " does not support ", show pv] + Just machPars -> machPars {-| 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 :: MajorProtocolVersion -> DefaultMachineParameters +data EvaluationContext = EvaluationContext + { _evalCtxLedgerLang :: PlutusLedgerLanguage + , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun + , _evalCtxMachParsList :: [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)] } deriving stock Generic deriving anyclass (NFData, NoThunks) @@ -128,18 +134,13 @@ with the updated cost model parameters. -} mkDynEvaluationContext :: MonadError CostModelApplyError m - => String + => PlutusLedgerLanguage -> [BuiltinSemanticsVariant DefaultFun] -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> Plutus.CostModelParams -> m EvaluationContext 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 + EvaluationContext lv toSemVar <$> mkMachineParametersFor semVars newCMP -- FIXME: remove this function assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m () diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 1811ba39f72..0d02e37605f 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -1,5 +1,7 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} + {- | This module contains the code for handling the various kinds of version that we care about: * Protocol versions @@ -28,6 +30,7 @@ import PlutusPrelude import Data.Map qualified as Map import Data.Set qualified as Set +import NoThunks.Class (NoThunks) import PlutusCore.Version (plcVersion100, plcVersion110) import Prettyprinter @@ -72,6 +75,7 @@ data PlutusLedgerLanguage = | PlutusV2 -- ^ introduced in vasil era | PlutusV3 -- ^ not yet enabled deriving stock (Eq, Ord, Show, Generic, Enum, Bounded) + deriving anyclass (NFData, NoThunks) instance Pretty PlutusLedgerLanguage where pretty = viaShow diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index 8b047a1bd7c..4713c7e6604 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -38,7 +38,7 @@ mkEvaluationContext = tagWithParamNames @V1.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - "PlutusV1" + PlutusV1 [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV then DefaultFunSemanticsVariant0 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index d3d51a60086..6ba0d7113f2 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -38,7 +38,7 @@ mkEvaluationContext = tagWithParamNames @V2.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - "PlutusV2" + PlutusV2 [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV then Plutus.DefaultFunSemanticsVariant0 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index ee2bd5657ea..877a412b385 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -36,6 +36,6 @@ mkEvaluationContext = tagWithParamNames @V3.ParamName >=> pure . toCostModelParams >=> mkDynEvaluationContext - "PlutusV3" + PlutusV3 [DefaultFunSemanticsVariant2] (const Plutus.DefaultFunSemanticsVariant2) From 846ae8ea76c3bbaa7876baa7ffe886cdf96fab21 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 16 Apr 2024 13:28:15 +0200 Subject: [PATCH 22/29] Remove a bang --- .../PlutusCore/Evaluation/Machine/MachineParameters/Default.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index b086fd07a67..6c3fce10010 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -1,5 +1,3 @@ -{-# 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. From ae5718bacca6b88f580cc483571a5ed00ce108c5 Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 18 Apr 2024 15:41:41 +0200 Subject: [PATCH 23/29] Add 'evaluationContextCacheIsComplete' --- .../Machine/MachineParameters/Default.hs | 2 +- plutus-ledger-api/plutus-ledger-api.cabal | 1 - .../src/PlutusLedgerApi/Common/Eval.hs | 2 +- plutus-ledger-api/test/Spec.hs | 2 - plutus-ledger-api/test/Spec/Eval.hs | 57 +++++++++++++++-- plutus-ledger-api/test/Spec/NoThunks.hs | 63 ------------------- 6 files changed, 55 insertions(+), 72 deletions(-) delete mode 100644 plutus-ledger-api/test/Spec/NoThunks.hs diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 6c3fce10010..3558489c1f9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -59,7 +59,7 @@ inlining). -- This function is expensive, so its result needs to be cached if it's going to be used multiple -- times. mkMachineParametersFor - :: forall m. MonadError CostModelApplyError m + :: MonadError CostModelApplyError m => [BuiltinSemanticsVariant DefaultFun] -> CostModelParams -> m [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)] diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 06f96500519..8d0c12a4ebc 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -151,7 +151,6 @@ test-suite plutus-ledger-api-test Spec.CostModelParams Spec.Eval Spec.Interval - Spec.NoThunks Spec.ScriptDecodeError Spec.V1.Value Spec.Versions diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 2498811dcdd..935a64d38ee 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -109,7 +109,7 @@ toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachi toMachineParameters pv (EvaluationContext lv toSemVar machParsList) = case lookup (toSemVar pv) machParsList of Nothing -> error $ Prelude.concat - ["Internal error: ", show lv, " does not support ", show pv] + ["Internal error: ", show lv, " does not support protocol version ", show pv] Just machPars -> machPars {-| An opaque type that contains all the static parameters that the evaluator needs to evaluate a diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index 2380a62711b..b5ab67329e2 100644 --- a/plutus-ledger-api/test/Spec.hs +++ b/plutus-ledger-api/test/Spec.hs @@ -11,7 +11,6 @@ import Spec.ContextDecoding qualified import Spec.CostModelParams qualified import Spec.Eval qualified import Spec.Interval qualified -import Spec.NoThunks qualified import Spec.ScriptDecodeError qualified import Spec.V1.Value qualified as Value import Spec.Versions qualified @@ -105,7 +104,6 @@ tests = testGroup "plutus-ledger-api"[ , Spec.Eval.tests , Spec.Versions.tests , Spec.CostModelParams.tests - , Spec.NoThunks.tests , Spec.CBOR.DeserialiseFailureInfo.tests , Spec.ScriptDecodeError.tests , Spec.ContextDecoding.tests diff --git a/plutus-ledger-api/test/Spec/Eval.hs b/plutus-ledger-api/test/Spec/Eval.hs index 99305666a70..fe945a30f9b 100644 --- a/plutus-ledger-api/test/Spec/Eval.hs +++ b/plutus-ledger-api/test/Spec/Eval.hs @@ -1,25 +1,35 @@ -- editorconfig-checker-disable-file -- TODO: merge this module to Versions.hs ? +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Spec.Eval (tests) where import PlutusCore.Default import PlutusCore.Evaluation.Machine.ExBudget +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults import PlutusCore.MkPlc +import PlutusCore.Pretty import PlutusCore.StdLib.Data.Unit import PlutusCore.Version as PLC import PlutusLedgerApi.Common import PlutusLedgerApi.Common.Versions import PlutusLedgerApi.Test.V1.EvaluationContext qualified as V1 import PlutusLedgerApi.V1 qualified as V1 +import PlutusLedgerApi.V2 qualified as V2 +import PlutusLedgerApi.V3 qualified as V3 import PlutusPrelude import UntypedPlutusCore as UPLC import UntypedPlutusCore.Test.DeBruijn.Bad import UntypedPlutusCore.Test.DeBruijn.Good - +import Control.Exception (evaluate) +import Control.Monad.Extra (whenJust) import Control.Monad.Writer +import Data.Foldable (for_) +import Data.Map qualified as Map +import Data.Maybe (fromJust) +import NoThunks.Class import Test.Tasty import Test.Tasty.HUnit @@ -73,8 +83,47 @@ testUnlifting = testCase "check unlifting behaviour changes in Vasil" $ do evalAPI alonzoPV illPartialBuiltin @?= True evalAPI vasilPV illPartialBuiltin @?= True +costParams :: [Integer] +costParams = Map.elems (fromJust defaultCostModelParams) + +lengthParamNamesV :: PlutusLedgerLanguage -> Int +lengthParamNamesV PlutusV1 = length $ enumerate @V1.ParamName +lengthParamNamesV PlutusV2 = length $ enumerate @V2.ParamName +lengthParamNamesV PlutusV3 = length $ enumerate @V3.ParamName + +mkEvaluationContextV :: PlutusLedgerLanguage -> IO EvaluationContext +mkEvaluationContextV lv = + either (assertFailure . display) (pure . fst) . runWriterT $ + take (lengthParamNamesV lv) costParams & case lv of + PlutusV1 -> V1.mkEvaluationContext + PlutusV2 -> V2.mkEvaluationContext + PlutusV3 -> V3.mkEvaluationContext + +-- | Ensure that 'toMachineParameters' never throws for all language and protocol versions. +evaluationContextCacheIsComplete :: TestTree +evaluationContextCacheIsComplete = + testGroup "EvaluationContext has machine parameters for all protocol versions" $ + enumerate <&> \lv -> testCase (show lv) $ do + evalCtx <- mkEvaluationContextV lv + for_ knownPVs $ \pv -> evaluate $ toMachineParameters pv evalCtx + +failIfThunk :: Show a => Maybe a -> IO () +failIfThunk mbThunkInfo = + whenJust mbThunkInfo $ \thunkInfo -> + assertFailure $ "Unexpected thunk: " <> show thunkInfo + +-- | Ensure that no 'EvaluationContext' has thunks in it for all language versions. +evaluationContextNoThunks :: TestTree +evaluationContextNoThunks = + testGroup "NoThunks in EvaluationContext" $ + enumerate <&> \lv -> testCase (show lv) $ do + !evalCtx <- mkEvaluationContextV lv + failIfThunk =<< noThunks [] evalCtx + tests :: TestTree tests = testGroup "eval" - [ testAPI - , testUnlifting - ] + [ testAPI + , testUnlifting + , evaluationContextCacheIsComplete + , evaluationContextNoThunks + ] diff --git a/plutus-ledger-api/test/Spec/NoThunks.hs b/plutus-ledger-api/test/Spec/NoThunks.hs deleted file mode 100644 index f6862d82859..00000000000 --- a/plutus-ledger-api/test/Spec/NoThunks.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} - -module Spec.NoThunks (tests) where - -import NoThunks.Class - -import PlutusLedgerApi.V1 as V1 -import PlutusLedgerApi.V2 as V2 -import PlutusLedgerApi.V3 as V3 - -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults as Plutu -import PlutusCore.Pretty - -import Control.Monad.Except -import Control.Monad.Extra (whenJust) -import Control.Monad.Writer.Strict -import Data.List.Extra (enumerate) -import Data.Map qualified as Map -import Data.Maybe (fromJust) -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup - "NoThunks" - [ testCase "EvaluationContext V1" evaluationContextV1 - , testCase "EvaluationContext V2" evaluationContextV2 - , testCase "EvaluationContext V3" evaluationContextV3 - ] - -costParams :: [Integer] -costParams = Map.elems (fromJust defaultCostModelParams) - -evaluationContextV1 :: Assertion -evaluationContextV1 = do - let v1CostParams = take (length $ enumerate @V1.ParamName) costParams - !(evalCtx :: EvaluationContext) <- - either (assertFailure . display) (pure . fst) $ runExcept $ runWriterT $ - V1.mkEvaluationContext v1CostParams - failIfThunk =<< noThunks [] evalCtx - -evaluationContextV2 :: Assertion -evaluationContextV2 = do - let v2CostParams = take (length $ enumerate @V2.ParamName) costParams - !(evalCtx :: EvaluationContext) <- - either (assertFailure . display) (pure . fst) $ runExcept $ runWriterT $ - V2.mkEvaluationContext v2CostParams - failIfThunk =<< noThunks [] evalCtx - -evaluationContextV3 :: Assertion -evaluationContextV3 = do - let v3CostParams = take (length $ enumerate @V3.ParamName) costParams - !(evalCtx :: EvaluationContext) <- - either (assertFailure . display) (pure . fst) $ runExcept $ runWriterT $ - V3.mkEvaluationContext v3CostParams - failIfThunk =<< noThunks [] evalCtx - -failIfThunk :: Show a => Maybe a -> IO () -failIfThunk mbThunkInfo = - whenJust mbThunkInfo $ \thunkInfo -> - assertFailure $ "Unexpected thunk: " <> show thunkInfo From 809675d0697b8309808cdeb4fdc66244583e0062 Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 19 Apr 2024 00:16:46 +0200 Subject: [PATCH 24/29] Refactoring and comments --- plutus-benchmark/bls12-381-costs/bench/Bench.hs | 3 +-- plutus-benchmark/cek-calibration/Main.hs | 3 +-- plutus-benchmark/lists/bench/Bench.hs | 3 +-- plutus-benchmark/marlowe/bench/BenchCek.hs | 3 +-- plutus-benchmark/nofib/bench/BenchCek.hs | 3 +-- plutus-benchmark/validation/bench/BenchCek.hs | 3 +-- plutus-benchmark/validation/bench/BenchFull.hs | 3 +-- .../Machine/MachineParameters/Default.hs | 14 +++++++++----- .../src/PlutusLedgerApi/Common/Eval.hs | 17 +++++++++++++---- 9 files changed, 29 insertions(+), 23 deletions(-) diff --git a/plutus-benchmark/bls12-381-costs/bench/Bench.hs b/plutus-benchmark/bls12-381-costs/bench/Bench.hs index d7e92e10733..c656f6e3e0c 100644 --- a/plutus-benchmark/bls12-381-costs/bench/Bench.hs +++ b/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] diff --git a/plutus-benchmark/cek-calibration/Main.hs b/plutus-benchmark/cek-calibration/Main.hs index 31d4d6d407b..5569f529136 100644 --- a/plutus-benchmark/cek-calibration/Main.hs +++ b/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]] diff --git a/plutus-benchmark/lists/bench/Bench.hs b/plutus-benchmark/lists/bench/Bench.hs index 7e38a4efe58..5459644fcf2 100644 --- a/plutus-benchmark/lists/bench/Bench.hs +++ b/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 diff --git a/plutus-benchmark/marlowe/bench/BenchCek.hs b/plutus-benchmark/marlowe/bench/BenchCek.hs index 2c30e5a49fd..3c1c341a627 100644 --- a/plutus-benchmark/marlowe/bench/BenchCek.hs +++ b/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) diff --git a/plutus-benchmark/nofib/bench/BenchCek.hs b/plutus-benchmark/nofib/bench/BenchCek.hs index 17ff4b47dcd..920d64e8971 100644 --- a/plutus-benchmark/nofib/bench/BenchCek.hs +++ b/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 diff --git a/plutus-benchmark/validation/bench/BenchCek.hs b/plutus-benchmark/validation/bench/BenchCek.hs index 0c67ef49746..3bcae15800a 100644 --- a/plutus-benchmark/validation/bench/BenchCek.hs +++ b/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 diff --git a/plutus-benchmark/validation/bench/BenchFull.hs b/plutus-benchmark/validation/bench/BenchFull.hs index 2b7b628c804..09e97281687 100644 --- a/plutus-benchmark/validation/bench/BenchFull.hs +++ b/plutus-benchmark/validation/bench/BenchFull.hs @@ -7,7 +7,6 @@ import PlutusLedgerApi.V1 import UntypedPlutusCore qualified as UPLC import Common -import Control.DeepSeq (force) import Control.Exception import Criterion import Data.ByteString as BS @@ -23,7 +22,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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 3558489c1f9..902ce8360f0 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -44,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 @@ -56,8 +57,8 @@ 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] @@ -65,9 +66,12 @@ mkMachineParametersFor -> 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 - pure $ force res + -- Force all thunks to pay the costs 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. diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 935a64d38ee..1b1823ad788 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -117,18 +117,27 @@ script. This is so that they can be computed once and cached, rather than being evaluation. -} data EvaluationContext = EvaluationContext - { _evalCtxLedgerLang :: PlutusLedgerLanguage - , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun - , _evalCtxMachParsList :: [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)] + { _evalCtxLedgerLang :: PlutusLedgerLanguage + -- ^ Specifies what language versions the 'EvaluationContext' is for. + , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun + -- ^ Specifies how to get a semantics variant given a 'MajorProtocolVersion'. + , _evalCtxMachParsCache :: [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)] + -- ^ The cache of 'DefaultMachineParameters' for each semantics variant supported by the + -- current language version. } deriving stock Generic deriving anyclass (NFData, NoThunks) -{-| Create an 'EvaluationContext' for a given builtin semantics variant. +{-| Create an 'EvaluationContext' given all builtin semantics variant supported by the provided +language version. The input is a `Map` of `Text`s to cost integer values (aka `Plutus.CostModelParams`, `Alonzo.CostModel`) See Note [Inlining meanings of builtins]. +IMPORTANT: the 'toSemVar' argument computes the semantics variant for each 'MajorProtocolVersion' +and it must only return semantics variants from the 'semVars' list, as well as cover ANY +'MajorProtocolVersion', including those that do not exist yet (i.e. 'toSemVar' must never fail). + IMPORTANT: The evaluation context of every Plutus version must be recreated upon a protocol update with the updated cost model parameters. -} From 28f46c737ac1aad9b762536718165adf95cb0bab Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 19 Apr 2024 00:43:39 +0200 Subject: [PATCH 25/29] More comments --- plutus-benchmark/plutus-benchmark.cabal | 7 ------- .../src/PlutusLedgerApi/Common/Eval.hs | 16 ++++++++++++++-- plutus-ledger-api/test/Spec/Eval.hs | 4 +++- 3 files changed, 17 insertions(+), 10 deletions(-) diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 7e21837fda6..7d088157368 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/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 @@ -262,7 +260,6 @@ benchmark validation , base >=4.9 && <5 , bytestring , criterion >=1.5.9.0 - , deepseq , directory , filepath , flat ^>=0.6 @@ -303,7 +300,6 @@ benchmark validation-full , base >=4.9 && <5 , bytestring , criterion >=1.5.9.0 - , deepseq , directory , filepath , flat ^>=0.6 @@ -323,7 +319,6 @@ benchmark cek-calibration build-depends: , base >=4.9 && <5 , criterion >=1.5.9.0 - , deepseq , lens , mtl , plutus-benchmark-common @@ -425,7 +420,6 @@ benchmark bls12-381-benchmarks , bls12-381lib-internal , bytestring , criterion >=1.5.9.0 - , deepseq , plutus-benchmark-common , plutus-ledger-api ^>=1.25 , plutus-tx ^>=1.25 @@ -518,7 +512,6 @@ benchmark marlowe build-depends: , base >=4.9 && <5 , criterion - , deepseq , marlowe-internal , plutus-benchmark-common , plutus-ledger-api ^>=1.25 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 1b1823ad788..4aa9e00ba66 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -113,8 +113,20 @@ toMachineParameters pv (EvaluationContext lv toSemVar machParsList) = Just machPars -> machPars {-| 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 +script. This is so that they can be computed once and cached, rather than being recomputed on every evaluation. + +Different protocol versions may require different bundles of machine parameters, which allows us for +example to tweak the shape of the costing function of a builtin, so that the builtin costs less. +Currently this means that we have to create multiple 'DefaultMachineParameters' per language +version, which we put into a cache (represented by an association list) in order to avoid costly +recomputation of machine parameters. + +In order to get the appropriate 'DefaultMachineParameters' at validation time we look it up in the +cache using a semantics variant as a key. We compute the semantics variant from the protocol +version using the stored function. Note that the semantics variant depends on the language version +too, but the latter is known statically (because each language version has its own evaluation +context), hence there's no reason to require it to be provided at runtime. -} data EvaluationContext = EvaluationContext { _evalCtxLedgerLang :: PlutusLedgerLanguage @@ -128,7 +140,7 @@ data EvaluationContext = EvaluationContext deriving stock Generic deriving anyclass (NFData, NoThunks) -{-| Create an 'EvaluationContext' given all builtin semantics variant supported by the provided +{-| Create an 'EvaluationContext' given all builtin semantics variants supported by the provided language version. The input is a `Map` of `Text`s to cost integer values (aka `Plutus.CostModelParams`, `Alonzo.CostModel`) diff --git a/plutus-ledger-api/test/Spec/Eval.hs b/plutus-ledger-api/test/Spec/Eval.hs index fe945a30f9b..5634a5f1410 100644 --- a/plutus-ledger-api/test/Spec/Eval.hs +++ b/plutus-ledger-api/test/Spec/Eval.hs @@ -29,6 +29,7 @@ import Control.Monad.Writer import Data.Foldable (for_) import Data.Map qualified as Map import Data.Maybe (fromJust) +import Data.Set qualified as Set import NoThunks.Class import Test.Tasty import Test.Tasty.HUnit @@ -105,7 +106,8 @@ evaluationContextCacheIsComplete = testGroup "EvaluationContext has machine parameters for all protocol versions" $ enumerate <&> \lv -> testCase (show lv) $ do evalCtx <- mkEvaluationContextV lv - for_ knownPVs $ \pv -> evaluate $ toMachineParameters pv evalCtx + for_ (Set.insert futurePV knownPVs) $ \pv -> + evaluate $ toMachineParameters pv evalCtx failIfThunk :: Show a => Maybe a -> IO () failIfThunk mbThunkInfo = From 9d8942da1696208f3c5cc3a0a7ad67c33910eecf Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 19 Apr 2024 00:58:02 +0200 Subject: [PATCH 26/29] Comments and fixes --- plutus-benchmark/plutus-benchmark.cabal | 1 + plutus-benchmark/validation/bench/BenchFull.hs | 1 + .../Evaluation/Machine/MachineParameters/Default.hs | 2 +- plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs | 9 +++++++++ 4 files changed, 12 insertions(+), 1 deletion(-) diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 7d088157368..624b371f4d3 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -300,6 +300,7 @@ benchmark validation-full , base >=4.9 && <5 , bytestring , criterion >=1.5.9.0 + , deepseq , directory , filepath , flat ^>=0.6 diff --git a/plutus-benchmark/validation/bench/BenchFull.hs b/plutus-benchmark/validation/bench/BenchFull.hs index 09e97281687..85cb1ae77dc 100644 --- a/plutus-benchmark/validation/bench/BenchFull.hs +++ b/plutus-benchmark/validation/bench/BenchFull.hs @@ -7,6 +7,7 @@ import PlutusLedgerApi.V1 import UntypedPlutusCore qualified as UPLC import Common +import Control.DeepSeq (force) import Control.Exception import Criterion import Data.ByteString as BS diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 902ce8360f0..91e0733b630 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -69,7 +69,7 @@ mkMachineParametersFor semVars newCMP = do -- See Note [Inlining meanings of builtins]. (,) semVar . inline mkMachineParameters semVar <$> applyCostModelParams (toCekCostModel semVar) newCMP - -- Force all thunks to pay the costs of creating machine parameters upfront. Doing it here saves + -- 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 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 4aa9e00ba66..bc911857220 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -127,6 +127,15 @@ cache using a semantics variant as a key. We compute the semantics variant from version using the stored function. Note that the semantics variant depends on the language version too, but the latter is known statically (because each language version has its own evaluation context), hence there's no reason to require it to be provided at runtime. + +The reason why we associate a 'DefaultMachineParameters' with a semantics variant rather than a +protocol version are + +1. generally there are far more protocol versions than semantics variants supported by a specific + language version, so we save on pointless duplication of bundles of machine parameters +2. builtins don't know anything about protocol versions, only semantics variants. It is therefore + more semantically precise to associate bundles of machine parameters with semantics variants than + with protocol versions -} data EvaluationContext = EvaluationContext { _evalCtxLedgerLang :: PlutusLedgerLanguage From 039dce11b8ad706c04d5bb452ee14d787e865d64 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 23 Apr 2024 18:31:18 +0200 Subject: [PATCH 27/29] Tweaks --- .../src/PlutusLedgerApi/Common/Eval.hs | 14 +++++++++----- .../src/PlutusLedgerApi/Common/SerialisedScript.hs | 6 +++--- .../src/PlutusLedgerApi/Common/Versions.hs | 4 ++-- .../src/PlutusLedgerApi/V2/EvaluationContext.hs | 6 +++--- .../src/PlutusLedgerApi/V3/EvaluationContext.hs | 4 ++-- plutus-ledger-api/test/Spec/Eval.hs | 12 ++++++------ 6 files changed, 25 insertions(+), 21 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index bc911857220..9517e8465c0 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -106,10 +106,10 @@ mkTermToEvaluate ll pv script args = do through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters -toMachineParameters pv (EvaluationContext lv toSemVar machParsList) = +toMachineParameters pv (EvaluationContext ll toSemVar machParsList) = case lookup (toSemVar pv) machParsList of Nothing -> error $ Prelude.concat - ["Internal error: ", show lv, " does not support protocol version ", show pv] + ["Internal error: ", show ll, " does not support protocol version ", show pv] Just machPars -> machPars {-| An opaque type that contains all the static parameters that the evaluator needs to evaluate a @@ -128,6 +128,9 @@ version using the stored function. Note that the semantics variant depends on th too, but the latter is known statically (because each language version has its own evaluation context), hence there's no reason to require it to be provided at runtime. +To say it differently, there's a matrix of semantics variants indexed by (LL, PV) pairs and we +cache its particular row corresponding to the statically given LL in an 'EvaluationContext'. + The reason why we associate a 'DefaultMachineParameters' with a semantics variant rather than a protocol version are @@ -141,7 +144,8 @@ data EvaluationContext = EvaluationContext { _evalCtxLedgerLang :: PlutusLedgerLanguage -- ^ Specifies what language versions the 'EvaluationContext' is for. , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun - -- ^ Specifies how to get a semantics variant given a 'MajorProtocolVersion'. + -- ^ Specifies how to get a semantics variant for this ledger language given a + -- 'MajorProtocolVersion'. , _evalCtxMachParsCache :: [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)] -- ^ The cache of 'DefaultMachineParameters' for each semantics variant supported by the -- current language version. @@ -169,8 +173,8 @@ mkDynEvaluationContext -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> Plutus.CostModelParams -> m EvaluationContext -mkDynEvaluationContext lv semVars toSemVar newCMP = - EvaluationContext lv toSemVar <$> mkMachineParametersFor semVars newCMP +mkDynEvaluationContext ll semVars toSemVar newCMP = + EvaluationContext ll toSemVar <$> mkMachineParametersFor semVars newCMP -- FIXME: remove this function assertWellFormedCostModelParams :: MonadError CostModelApplyError m => Plutus.CostModelParams -> m () diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs index 4690e639cc3..249c4a63c73 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs @@ -195,9 +195,9 @@ scriptCBORDecoder :: PlutusLedgerLanguage -> MajorProtocolVersion -> CBOR.Decoder s ScriptNamedDeBruijn -scriptCBORDecoder lv pv = +scriptCBORDecoder ll pv = -- See Note [New builtins/language versions and protocol versions] - let availableBuiltins = builtinsAvailableIn lv pv + let availableBuiltins = builtinsAvailableIn ll pv flatDecoder = UPLC.decodeProgram checkBuiltin -- TODO: optimize this by using a better datastructure e.g. 'IntSet' checkBuiltin f | f `Set.member` availableBuiltins = Nothing @@ -206,7 +206,7 @@ scriptCBORDecoder lv pv = "Builtin function " ++ show f ++ " is not available in language " - ++ show (pretty lv) + ++ show (pretty ll) ++ " at and protocol version " ++ show (pretty pv) in do diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 0d02e37605f..728b096ea3c 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -149,8 +149,8 @@ ledgerLanguagesAvailableIn searchPv = where -- OPTIMIZE: could be done faster using takeWhile ledgerVersionToSet :: PlutusLedgerLanguage -> Set.Set PlutusLedgerLanguage - ledgerVersionToSet lv - | ledgerLanguageIntroducedIn lv <= searchPv = Set.singleton lv + ledgerVersionToSet ll + | ledgerLanguageIntroducedIn ll <= searchPv = Set.singleton ll | otherwise = mempty {-| Which Plutus Core language versions are available in the given 'PlutusLedgerLanguage' diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 6ba0d7113f2..4da1caea16a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -13,7 +13,7 @@ import PlutusLedgerApi.Common import PlutusLedgerApi.Common.Versions (conwayPV) import PlutusLedgerApi.V2.ParamName as V2 -import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) +import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) import Control.Monad import Control.Monad.Except @@ -41,5 +41,5 @@ mkEvaluationContext = PlutusV2 [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] (\pv -> if pv < conwayPV - then Plutus.DefaultFunSemanticsVariant0 - else Plutus.DefaultFunSemanticsVariant1) + then DefaultFunSemanticsVariant0 + else DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index 877a412b385..ad177910c72 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -11,7 +11,7 @@ module PlutusLedgerApi.V3.EvaluationContext import PlutusLedgerApi.Common import PlutusLedgerApi.V3.ParamName as V3 -import PlutusCore.Default as Plutus (BuiltinSemanticsVariant (DefaultFunSemanticsVariant2)) +import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariant2)) import Control.Monad import Control.Monad.Except @@ -38,4 +38,4 @@ mkEvaluationContext = >=> mkDynEvaluationContext PlutusV3 [DefaultFunSemanticsVariant2] - (const Plutus.DefaultFunSemanticsVariant2) + (const DefaultFunSemanticsVariant2) diff --git a/plutus-ledger-api/test/Spec/Eval.hs b/plutus-ledger-api/test/Spec/Eval.hs index 5634a5f1410..9919f50a491 100644 --- a/plutus-ledger-api/test/Spec/Eval.hs +++ b/plutus-ledger-api/test/Spec/Eval.hs @@ -93,9 +93,9 @@ lengthParamNamesV PlutusV2 = length $ enumerate @V2.ParamName lengthParamNamesV PlutusV3 = length $ enumerate @V3.ParamName mkEvaluationContextV :: PlutusLedgerLanguage -> IO EvaluationContext -mkEvaluationContextV lv = +mkEvaluationContextV ll = either (assertFailure . display) (pure . fst) . runWriterT $ - take (lengthParamNamesV lv) costParams & case lv of + take (lengthParamNamesV ll) costParams & case ll of PlutusV1 -> V1.mkEvaluationContext PlutusV2 -> V2.mkEvaluationContext PlutusV3 -> V3.mkEvaluationContext @@ -104,8 +104,8 @@ mkEvaluationContextV lv = evaluationContextCacheIsComplete :: TestTree evaluationContextCacheIsComplete = testGroup "EvaluationContext has machine parameters for all protocol versions" $ - enumerate <&> \lv -> testCase (show lv) $ do - evalCtx <- mkEvaluationContextV lv + enumerate <&> \ll -> testCase (show ll) $ do + evalCtx <- mkEvaluationContextV ll for_ (Set.insert futurePV knownPVs) $ \pv -> evaluate $ toMachineParameters pv evalCtx @@ -118,8 +118,8 @@ failIfThunk mbThunkInfo = evaluationContextNoThunks :: TestTree evaluationContextNoThunks = testGroup "NoThunks in EvaluationContext" $ - enumerate <&> \lv -> testCase (show lv) $ do - !evalCtx <- mkEvaluationContextV lv + enumerate <&> \ll -> testCase (show ll) $ do + !evalCtx <- mkEvaluationContextV ll failIfThunk =<< noThunks [] evalCtx tests :: TestTree From 1f1bf5e69725965679936e869b773358e16c51d1 Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 25 Apr 2024 18:13:44 +0200 Subject: [PATCH 28/29] Add 'Note [Mapping of protocol versions and ledger languages to semantics variants]' --- .../Evaluation/Machine/ExBudgetingDefaults.hs | 2 ++ .../PlutusLedgerApi/Common/ProtocolVersions.hs | 18 ++++++++++++++++++ .../PlutusLedgerApi/V1/EvaluationContext.hs | 1 + .../PlutusLedgerApi/V2/EvaluationContext.hs | 1 + .../PlutusLedgerApi/V3/EvaluationContext.hs | 1 + 5 files changed, 23 insertions(+) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 8fcb171cc38..309095f60db 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -86,6 +86,8 @@ 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 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs index b1cc1ea06d6..fdf7fbc08a5 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs @@ -83,3 +83,21 @@ knownPVs = Set.fromList [ shelleyPV, allegraPV, maryPV, alonzoPV, vasilPV, valen -- associate something with the wrong protocol version. futurePV :: MajorProtocolVersion futurePV = MajorProtocolVersion maxBound + +{- Note [Mapping of protocol versions and ledger languages to semantics variants] +Semantics variants depend on both the protocol version and the ledger language. + +Here's a table specifying the mapping in full: + + pv pre-Conway post-Conway +ll +1 0 1 +2 0 1 +3 2 2 + +I.e. for example + +- post-Conway 'PlutusV1' corresponds to 'DefaultFunSemanticsVariant1' +- pre-Conway 'PlutusV2' corresponds to 'DefaultFunSemanticsVariant0' +- post-Conway 'PlutusV3' corresponds to 'DefaultFunSemanticsVariant2' +-} diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index d3121ee8e44..6cb246a2b00 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -41,6 +41,7 @@ mkEvaluationContext = >=> mkDynEvaluationContext PlutusV1 [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] + -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. (\pv -> if pv < conwayPV then DefaultFunSemanticsVariant0 else DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 3b4137627b7..339c4be4872 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -41,6 +41,7 @@ mkEvaluationContext = >=> mkDynEvaluationContext PlutusV2 [DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1] + -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. (\pv -> if pv < conwayPV then DefaultFunSemanticsVariant0 else DefaultFunSemanticsVariant1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index db882c30f5f..a7ba8f24089 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -39,4 +39,5 @@ mkEvaluationContext = >=> mkDynEvaluationContext PlutusV3 [DefaultFunSemanticsVariant2] + -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. (const DefaultFunSemanticsVariant2) From e507daefe08c379fa5df2a9221f0ffcc2b391fcf Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 25 Apr 2024 18:48:49 +0200 Subject: [PATCH 29/29] Add a changelog entry --- ...ajorProtocolVersion_and_multiple_CostModels.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 plutus-ledger-api/changelog.d/20240425_183853_effectfully_both_MajorProtocolVersion_and_multiple_CostModels.md diff --git a/plutus-ledger-api/changelog.d/20240425_183853_effectfully_both_MajorProtocolVersion_and_multiple_CostModels.md b/plutus-ledger-api/changelog.d/20240425_183853_effectfully_both_MajorProtocolVersion_and_multiple_CostModels.md new file mode 100644 index 00000000000..b740817e3d4 --- /dev/null +++ b/plutus-ledger-api/changelog.d/20240425_183853_effectfully_both_MajorProtocolVersion_and_multiple_CostModels.md @@ -0,0 +1,15 @@ +### Changed + +`EvaluationContext` now contains: + +- `PlutusLedgerLanguage` -- a ledger language +- `MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun` -- a function returning a semantics variant for every protocol version +- `[(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]` -- a cache of machine parameters for each semantics variant supported by the ledger language + +Similarly, `mkDynEvaluationContext` now takes additional arguments: + +- `PlutusLedgerLanguage` -- same as above +- `[BuiltinSemanticsVariant DefaultFun]` -- a list of semantics variants supported by the ledger language +- `MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun` -- same as above + +All this allows us to improve the accuracy of costing in future protocol versions without introducing new ledger languages.