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/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 2c92a89b142..4db0cc4453c 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -162,7 +162,11 @@ mkEvalCtx = Just p -> let errOrCtx = -- The validation benchmarks were all created from PlutusV1 scripts - LedgerApi.mkDynEvaluationContext DefaultFunSemanticsVariant1 p + LedgerApi.mkDynEvaluationContext + LedgerApi.PlutusV1 + [DefaultFunSemanticsVariant1] + (const DefaultFunSemanticsVariant1) + p in case errOrCtx of Right ec -> ec Left err -> error $ show err 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/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 45244dddc40..aa7384fe458 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 ^>=1.26 @@ -262,7 +260,6 @@ benchmark validation , base >=4.9 && <5 , bytestring , criterion >=1.5.9.0 - , deepseq , directory , filepath , flat ^>=0.6 @@ -323,7 +320,6 @@ benchmark cek-calibration build-depends: , base >=4.9 && <5 , criterion >=1.5.9.0 - , deepseq , lens , mtl , plutus-benchmark-common @@ -425,7 +421,6 @@ benchmark bls12-381-benchmarks , bls12-381lib-internal , bytestring , criterion >=1.5.9.0 - , deepseq , plutus-benchmark-common , plutus-ledger-api ^>=1.26 , plutus-tx ^>=1.26 @@ -518,7 +513,6 @@ benchmark marlowe build-depends: , base >=4.9 && <5 , criterion - , deepseq , marlowe-internal , plutus-benchmark-common , plutus-ledger-api ^>=1.26 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..85cb1ae77dc 100644 --- a/plutus-benchmark/validation/bench/BenchFull.hs +++ b/plutus-benchmark/validation/bench/BenchFull.hs @@ -23,7 +23,7 @@ the whole time taken from script deserialization to script execution result. -} main :: IO () main = do - evalCtx <- evaluate $ force mkEvalCtx + evalCtx <- evaluate mkEvalCtx let mkFullBM :: FilePath -> BS.ByteString -> Benchmarkable mkFullBM file bsFlat = let UPLC.Program () ver body = unsafeUnflat file bsFlat diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index dff190546b6..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 modelParams of - Left _ -> Nothing - Right p -> Just p + params <- case mkMachineParametersFor [def] modelParams of + Left _ -> Nothing + Right machParamsList -> lookup def machParamsList -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with free variables, -- that is why we manually check first for any free vars case UPLC.deBruijnTerm t of 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 23b3a6ba481..a8838df74fd 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -30,7 +30,6 @@ import PlutusCore.Evaluation.Machine.ExBudgetStream import PlutusCore.Evaluation.Machine.ExMemoryUsage import PlutusCore.Name.Unique -import Control.DeepSeq import Data.Array import Data.Kind qualified as GHC import Data.Proxy @@ -399,22 +398,15 @@ toBuiltinsRuntime -> cost -> BuiltinsRuntime fun val toBuiltinsRuntime semvar cost = - let runtime = BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar - -- This pragma is very important, removing it destroys the carefully set up optimizations of - -- of costing functions (see Note [Optimizations of runCostingFun*]). The reason for that is - -- that if @runtime@ doesn't have a pragma, then GHC sees that it's only referenced once and - -- inlines it below, together with this entire function (since we tell GHC to), at which - -- point everything's inlined and we're completely at GHC's mercy to optimize things - -- properly. Unfortunately, GHC doesn't want to cooperate and push 'toBuiltinRuntime' to - -- the inside of the inlined to 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's - -- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a - -- lambda binding the @cost@ variable, which renders all the optimizations useless. By - -- using a @NOINLINE@ pragma we tell GHC to create a separate thunk, which it can properly - -- optimize, because the other bazillion things don't get in the way. - {-# NOINLINE runtime #-} - in - -- Force each 'BuiltinRuntime' to WHNF, so that the thunk is allocated and forced at - -- initialization time rather than at runtime. Not that we'd lose much by not forcing all - -- 'BuiltinRuntime's here, but why pay even very little if there's an easy way not to pay. - force runtime + -- A call to 'lazy' is to make sure that the returned 'BuiltinsRuntime' is properly cached in a + -- 'let'-binding. This makes it easier for GHC to optimize the internals of builtins, because + -- without a 'let'-binding GHC would sometimes refuse to cooperate and push 'toBuiltinRuntime' + -- to the inside of the inlined 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's + -- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a lambda + -- binding the @cost@ variable, which makes the optimizations useless. + -- By using 'lazy' we tell GHC to create a separate thunk, which it can properly optimize, + -- because the other bazillion things don't get in the way. We used to use an explicit + -- 'let'-binding marked with @NOINLINE@, but that turned out to be unreliable, because GHC + -- feels free to turn it into a join point instead of a proper thunk. + lazy . BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar {-# INLINE toBuiltinsRuntime #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 3a5b9fb4714..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]. @@ -1075,10 +1076,12 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where possibly different semantics. Note that DefaultFunSemanticsVariant1, DefaultFunSemanticsVariant1 etc. do not correspond directly to PlutusV1, PlutusV2 etc. in plutus-ledger-api: see Note [Builtin semantics variants]. -} - data BuiltinSemanticsVariant DefaultFun = - DefaultFunSemanticsVariant1 - | DefaultFunSemanticsVariant2 - deriving stock (Enum, Bounded, Show) + data BuiltinSemanticsVariant DefaultFun + = DefaultFunSemanticsVariant0 + | DefaultFunSemanticsVariant1 + | DefaultFunSemanticsVariant2 + deriving stock (Eq, Enum, Bounded, Show, Generic) + deriving anyclass (NFData, NoThunks) -- Integers toBuiltinMeaning @@ -1176,6 +1179,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where appendByteStringDenotation (runCostingFunTwoArguments . paramAppendByteString) + -- See Note [Builtin semantics variants] toBuiltinMeaning semvar ConsByteString = -- The costing function is the same for all variants of this builtin, -- but since the denotation of the builtin accepts constants of @@ -1185,26 +1189,26 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where :: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream costingFun = runCostingFunTwoArguments . paramConsByteString {-# INLINE costingFun #-} - -- See Note [Builtin semantics variants] - in case semvar of - DefaultFunSemanticsVariant1 -> + consByteStringMeaning_V1 = let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString consByteStringDenotation n xs = BS.cons (fromIntegral n) xs {-# INLINE consByteStringDenotation #-} in makeBuiltinMeaning consByteStringDenotation costingFun - -- For builtin semantics variants other (i.e. larger) than - -- DefaultFunSemanticsVariant1, the first input must be in range - -- [0..255]. See Note [How to add a built-in function: simple - -- cases] - DefaultFunSemanticsVariant2 -> + -- For builtin semantics variants larger than 'DefaultFunSemanticsVariant1', the first + -- input must be in range @[0..255]@. + consByteStringMeaning_V2 = let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString consByteStringDenotation = BS.cons {-# INLINE consByteStringDenotation #-} in makeBuiltinMeaning consByteStringDenotation costingFun + in case semvar of + DefaultFunSemanticsVariant0 -> consByteStringMeaning_V1 + DefaultFunSemanticsVariant1 -> consByteStringMeaning_V1 + DefaultFunSemanticsVariant2 -> consByteStringMeaning_V2 toBuiltinMeaning _semvar SliceByteString = let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString @@ -1287,7 +1291,8 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool verifyEd25519SignatureDenotation = case semvar of - DefaultFunSemanticsVariant1 -> verifyEd25519Signature_V1 + DefaultFunSemanticsVariant0 -> verifyEd25519Signature_V1 + DefaultFunSemanticsVariant1 -> verifyEd25519Signature_V2 DefaultFunSemanticsVariant2 -> verifyEd25519Signature_V2 {-# INLINE verifyEd25519SignatureDenotation #-} in makeBuiltinMeaning 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 3c43abe1d88..309095f60db 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 @@ -85,6 +86,11 @@ defaultCekMachineCosts = defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel +-- | Return the 'CostModel' corresponding to the given semantics variant. The dependency on the +-- semantics variant is what makes cost models configurable. +toCekCostModel :: BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel +toCekCostModel _ = defaultCekCostModel + -- | The default cost model data. This is exposed to the ledger, so let's not -- confuse anybody by mentioning the CEK machine defaultCostModelParams :: Maybe CostModelParams 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..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 @@ -3,6 +3,8 @@ -- we need to be able to visually inspect, hence we dedicate a separate file to it. module PlutusCore.Evaluation.Machine.MachineParameters.Default where +import PlutusPrelude + import PlutusCore.Builtin import PlutusCore.Default import PlutusCore.Evaluation.Machine.CostModelInterface @@ -10,6 +12,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) @@ -41,8 +44,9 @@ as we did have cases where sticking 'inline' on something that already had @INLI inlining). -} --- | Produce a 'DefaultMachineParameters' given the version of the default set of built-in functions --- and a 'CostModelParams', which gets applied on top of 'defaultCekCostModel'. +-- | Produce a 'DefaultMachineParameters' for each of the given semantics variants. +-- The 'CostModelParams' argument is used to update the costing parameters returned by +-- 'toCekCostModel' for each of the semantics variants. -- -- Whenever you need to evaluate UPLC in a performance-sensitive manner (e.g. in the production, -- for benchmarking, for cost calibration etc), you MUST use this definition for creating a @@ -53,16 +57,21 @@ inlining). -- Core; you change how it's exported (implicitly as a part of a whole-module export or explicitly -- as a single definition) -- you get the idea. -- --- This function is expensive, so its result needs to be cached if it's going to be used multiple --- times. +-- This function is very expensive, so its result needs to be cached if it's going to be used +-- multiple times. mkMachineParametersFor :: MonadError CostModelApplyError m - => BuiltinSemanticsVariant DefaultFun + => [BuiltinSemanticsVariant DefaultFun] -> CostModelParams - -> m DefaultMachineParameters -mkMachineParametersFor semvar newCMP = - inline mkMachineParameters semvar <$> - applyCostModelParams defaultCekCostModel newCMP + -> m [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)] +mkMachineParametersFor semVars newCMP = do + res <- for semVars $ \semVar -> + -- See Note [Inlining meanings of builtins]. + (,) semVar . inline mkMachineParameters semVar <$> + applyCostModelParams (toCekCostModel semVar) newCMP + -- Force all thunks to pay the cost of creating machine parameters upfront. Doing it here saves + -- us from doing that in every single benchmark runner. + pure $! force res -- Not marking this function with @INLINE@, since at this point everything we wanted to be inlined -- is inlined and there's zero reason to duplicate thousands and thousands of lines of Core down -- the line. diff --git a/plutus-core/testlib/PlutusIR/Pass/Test.hs b/plutus-core/testlib/PlutusIR/Pass/Test.hs index 46623137855..34a8b070248 100644 --- a/plutus-core/testlib/PlutusIR/Pass/Test.hs +++ b/plutus-core/testlib/PlutusIR/Pass/Test.hs @@ -4,14 +4,10 @@ {-# OPTIONS_GHC -Wno-orphans #-} module PlutusIR.Pass.Test where -import Control.Exception (throw) import Control.Monad.Except -import Data.Bifunctor (first) -import Data.Functor (void) import Data.Typeable import PlutusCore qualified as PLC import PlutusCore.Builtin -import PlutusCore.Default (BuiltinSemanticsVariant (..)) import PlutusCore.Generators.QuickCheck (forAllDoc) import PlutusCore.Pretty qualified as PLC import PlutusIR.Core.Type @@ -20,6 +16,7 @@ import PlutusIR.Generators.QuickCheck import PlutusIR.Pass import PlutusIR.TypeCheck import PlutusIR.TypeCheck qualified as TC +import PlutusPrelude import Test.QuickCheck -- Convert Either Error () to Either String () to match with the Testable (Either String ()) @@ -31,7 +28,7 @@ convertToEitherString = \case Right () -> Right () instance Arbitrary (BuiltinSemanticsVariant PLC.DefaultFun) where - arbitrary = elements [DefaultFunSemanticsVariant1, DefaultFunSemanticsVariant2] + arbitrary = elements enumerate -- | An appropriate number of tests for a compiler pass property, so that we get some decent -- exploration of the program space. If you also take other arguments, then consider multiplying 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..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 @@ -43,7 +43,8 @@ module UntypedPlutusCore.Evaluation.Machine.Cek , logWithTimeEmitter , logWithBudgetEmitter -- * Misc - , CekValue(..) + , BuiltinsRuntime (..) + , CekValue (..) , readKnownCek , Hashable , ThrowableBuiltins 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..c7d6eb915e8 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 @@ -770,6 +771,8 @@ test_ConsByteString = + 33 -- the index of '!' in ascii table expr1 = mkIterAppNoAnn (builtin () (Left ConsByteString :: DefaultFunExt)) [cons @Integer asciiBangWrapped, cons @ByteString "hello world"] + Right (EvaluationSuccess $ cons @ByteString "!hello world") @=? + typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant0 def) defaultBuiltinCostModelExt expr1 Right (EvaluationSuccess $ cons @ByteString "!hello world") @=? typecheckEvaluateCekNoEmit (PairV DefaultFunSemanticsVariant1 def) defaultBuiltinCostModelExt expr1 Right EvaluationFailure @=? typecheckEvaluateCekNoEmit @@ -802,6 +805,12 @@ test_SignatureVerification :: TestTree test_SignatureVerification = adjustOption (\x -> max x . HedgehogTestLimit . Just $ 8000) . testGroup "Signature verification" $ [ + testGroup "Ed25519 signatures (Variant0)" + [ testPropertyNamed + "Ed25519_Variant0 verification behaves correctly on all inputs" + "ed25519_Variant0_correct" + . property $ ed25519_Variant0Prop + ], testGroup "Ed25519 signatures (Variant1)" [ testPropertyNamed "Ed25519_Variant1 verification behaves correctly on all inputs" 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..3bd113cb378 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, @@ -75,6 +76,9 @@ ed25519Prop semvar = do cover 18 "happy path" . is (_Shouldn'tError . _AllGood) $ testCase runTestDataWith semvar testCase id VerifyEd25519Signature +ed25519_Variant0Prop :: PropertyT IO () +ed25519_Variant0Prop = ed25519Prop DefaultFunSemanticsVariant0 + ed25519_Variant1Prop :: PropertyT IO () ed25519_Variant1Prop = ed25519Prop DefaultFunSemanticsVariant1 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. diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index e737327be99..bf4c9c24dc0 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -149,7 +149,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 dbbe25f9cd0..9517e8465c0 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -106,33 +106,75 @@ mkTermToEvaluate ll pv script args = do through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters -toMachineParameters _ = machineParameters +toMachineParameters pv (EvaluationContext ll toSemVar machParsList) = + case lookup (toSemVar pv) machParsList of + Nothing -> error $ Prelude.concat + ["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 -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. + +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 + +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 -} -newtype EvaluationContext = EvaluationContext - { machineParameters :: DefaultMachineParameters +data EvaluationContext = EvaluationContext + { _evalCtxLedgerLang :: PlutusLedgerLanguage + -- ^ Specifies what language versions the 'EvaluationContext' is for. + , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun + -- ^ 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. } deriving stock Generic deriving anyclass (NFData, NoThunks) -{-| Create an 'EvaluationContext' for a given builtin semantics variant. +{-| 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`) 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. -} mkDynEvaluationContext :: MonadError CostModelApplyError m - => BuiltinSemanticsVariant DefaultFun + => PlutusLedgerLanguage + -> [BuiltinSemanticsVariant DefaultFun] + -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> Plutus.CostModelParams -> m EvaluationContext -mkDynEvaluationContext semvar newCMP = - EvaluationContext <$> mkMachineParametersFor semvar 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/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/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 1811ba39f72..728b096ea3c 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 @@ -145,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/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index 83a3527a4ea..6cb246a2b00 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 @@ -33,6 +35,13 @@ a protocol update with the updated cost model parameters. mkEvaluationContext :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => [Int64] -- ^ 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 + 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 df6dcacdccf..339c4be4872 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 (BuiltinSemanticsVariant (DefaultFunSemanticsVariant0, DefaultFunSemanticsVariant1)) import Control.Monad import Control.Monad.Except @@ -33,6 +35,13 @@ a protocol update with the updated cost model parameters. mkEvaluationContext :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => [Int64] -- ^ 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 + 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 5a34c211b8a..a7ba8f24089 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 @@ -33,6 +33,11 @@ a protocol update with the updated cost model parameters. mkEvaluationContext :: (MonadError CostModelApplyError m, MonadWriter [CostModelApplyWarn] m) => [Int64] -- ^ the (updated) cost model parameters of the protocol -> m EvaluationContext -mkEvaluationContext = tagWithParamNames @V3.ParamName - >=> pure . toCostModelParams - >=> mkDynEvaluationContext Plutus.DefaultFunSemanticsVariant2 +mkEvaluationContext = + tagWithParamNames @V3.ParamName + >=> pure . toCostModelParams + >=> mkDynEvaluationContext + PlutusV3 + [DefaultFunSemanticsVariant2] + -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. + (const DefaultFunSemanticsVariant2) diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs index f0854d4af92..dba560ad665 100644 --- a/plutus-ledger-api/test/Spec.hs +++ b/plutus-ledger-api/test/Spec.hs @@ -13,7 +13,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 @@ -123,7 +122,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..42871a0fca4 100644 --- a/plutus-ledger-api/test/Spec/Eval.hs +++ b/plutus-ledger-api/test/Spec/Eval.hs @@ -1,25 +1,37 @@ -- 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.Int (Int64) +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 @@ -73,8 +85,48 @@ testUnlifting = testCase "check unlifting behaviour changes in Vasil" $ do evalAPI alonzoPV illPartialBuiltin @?= True evalAPI vasilPV illPartialBuiltin @?= True +costParams :: [Int64] +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 ll = + either (assertFailure . display) (pure . fst) . runWriterT $ + take (lengthParamNamesV ll) costParams & case ll 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 <&> \ll -> testCase (show ll) $ do + evalCtx <- mkEvaluationContextV ll + for_ (Set.insert futurePV 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 <&> \ll -> testCase (show ll) $ do + !evalCtx <- mkEvaluationContextV ll + 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 af540b2b9e7..00000000000 --- a/plutus-ledger-api/test/Spec/NoThunks.hs +++ /dev/null @@ -1,64 +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.Int (Int64) -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 :: [Int64] -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