diff --git a/plutus-benchmark/validation/BenchDec.hs b/plutus-benchmark/validation/BenchDec.hs index ce5793f6bcd..bc174fc9460 100644 --- a/plutus-benchmark/validation/BenchDec.hs +++ b/plutus-benchmark/validation/BenchDec.hs @@ -7,6 +7,8 @@ import Data.ByteString as BS import Data.ByteString.Lazy as BSL import Data.ByteString.Short (toShort) import Plutus.V1.Ledger.Api +import Plutus.V1.Ledger.Scripts +import UntypedPlutusCore qualified as UPLC {-| for each data/*.flat validation script, it benchmarks @@ -21,11 +23,24 @@ main :: IO () main = benchWith mkDecBM where mkDecBM :: FilePath -> BS.ByteString -> Benchmarkable - mkDecBM _file bsFlat = + mkDecBM file bsFlat = let - -- just "envelope" the flat strict-bytestring into a cbor's lazy serialised bytestring - bslCBOR :: BSL.ByteString = Serialise.serialise bsFlat + UPLC.Program _ v (fullyApplied :: Term) = unsafeUnflat file bsFlat + + -- script arguments are not 64-byte size limited, so we make + -- sure to remove them from the fully-applied script, and then decode back just the "unsaturated" script + -- See Note [Deserialization size limits] + (unsaturated, _args) = peelDataArguments fullyApplied + + -- we then have to re-encode it + bslCBOR :: BSL.ByteString = Serialise.serialise (Script $ UPLC.Program () v unsaturated) -- strictify and "short" the result cbor to create a real `SerializedScript` + benchScript :: SerializedScript = toShort . BSL.toStrict $ bslCBOR - in whnf isScriptWellFormed benchScript + + -- Deserialize using 'FakeNamedDeBruijn' to get the fake names added + in whnf (\ s -> + isScriptWellFormed (ProtocolVersion 6 0) s + || error "validation script failed to decode" + ) benchScript diff --git a/plutus-benchmark/validation/BenchFull.hs b/plutus-benchmark/validation/BenchFull.hs index 6a6e000bead..79acf1f273b 100644 --- a/plutus-benchmark/validation/BenchFull.hs +++ b/plutus-benchmark/validation/BenchFull.hs @@ -11,23 +11,11 @@ import Criterion import Data.ByteString as BS import Data.ByteString.Lazy as BSL import Data.ByteString.Short (toShort) +import Data.Either -import PlutusCore.Builtin qualified as PLC -import PlutusCore.Data qualified as PLC +import PlutusCore.Evaluation.Machine.ExBudget import UntypedPlutusCore qualified as UPLC -type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () - --- | If the term is an application of something to some arguments, peel off --- those arguments which are 'Data' constants. -peelDataArguments :: Term -> (Term, [PLC.Data]) -peelDataArguments = go [] - where - go acc t@(UPLC.Apply () t' arg) = case PLC.readKnown Nothing arg of - Left _ -> (t, acc) - Right d -> go (d:acc) t' - go acc t = (t, acc) - {-| for each data/*.flat validation script, it benchmarks the whole time taken from script deserialization to script execution result. @@ -57,12 +45,16 @@ main = benchWith mkFullBM -- strictify and "short" the result cbor to create a real `SerializedScript` benchScript :: SerializedScript = toShort . BSL.toStrict $ bslCBOR - in whnf (\ script -> snd $ evaluateScriptCounting + in whnf (\ script -> + (isRight $ snd $ evaluateScriptRestricting (ProtocolVersion 6 0) -- no logs Quiet evalCtxForTesting + -- uses restricting(enormous) instead of counting to include the periodic budget-overspent check + (unExRestrictingBudget enormousBudget) script - args + args) + || error "script failed to run" ) benchScript diff --git a/plutus-benchmark/validation/Common.hs b/plutus-benchmark/validation/Common.hs index 68648019c6b..715e7af19c5 100644 --- a/plutus-benchmark/validation/Common.hs +++ b/plutus-benchmark/validation/Common.hs @@ -1,11 +1,20 @@ {-# LANGUAGE TypeApplications #-} -module Common (benchWith, unsafeUnflat, unsafeEvaluateCekNoEmit', throughCheckScope) where +module Common ( + benchWith + , unsafeUnflat + , unsafeEvaluateCekNoEmit' + , throughCheckScope + , peelDataArguments + , Term + ) where import PlutusBenchmark.Common (getConfig, getDataDir) import PlutusBenchmark.NaturalSort import Control.Monad.Except import PlutusCore qualified as PLC +import PlutusCore.Builtin qualified as PLC +import PlutusCore.Data qualified as PLC import PlutusCore.Evaluation.Machine.Exception import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Check.Scope (checkScope) @@ -133,3 +142,16 @@ unsafeEvaluateCekNoEmit' = PLC.defaultCekParameters UPLC.restrictingEnormous UPLC.noEmitter + +type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () + +-- | If the term is an application of something to some arguments, peel off +-- those arguments which are 'Data' constants. +peelDataArguments :: Term -> (Term, [PLC.Data]) +peelDataArguments = go [] + where + go acc t@(UPLC.Apply () t' arg) = case PLC.readKnown Nothing arg of + Left _ -> (t, acc) + Right d -> go (d:acc) t' + go acc t = (t, acc) + diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Api.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Api.hs index deb72041f7e..42ff42de143 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Api.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Api.hs @@ -115,7 +115,6 @@ module Plutus.V1.Ledger.Api ( import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Extras import Codec.CBOR.Read qualified as CBOR -import Codec.Serialise qualified as CBOR import Control.Monad.Except import Control.Monad.Writer import Data.Bifunctor @@ -170,17 +169,16 @@ internally. That means we don't lose anything by exposing all the details: we're anything, we're just going to create new versions. -} --- | Check if a 'Script' is "valid". At the moment this just means "deserialises correctly", which in particular --- implies that it is (almost certainly) an encoded script and cannot be interpreted as some other kind of encoded data. -isScriptWellFormed :: SerializedScript -> Bool -isScriptWellFormed = isRight . CBOR.deserialiseOrFail @Script . fromStrict . fromShort +-- | Check if a 'Script' is "valid" according to a protocol version. At the moment this means "deserialises correctly", which in particular +-- implies that it is (almost certainly) an encoded script and the script does not mention any builtins unavailable in the given protocol version. +isScriptWellFormed :: ProtocolVersion -> SerializedScript -> Bool +isScriptWellFormed pv = isRight . CBOR.deserialiseFromBytes (scriptCBORDecoder pv) . fromStrict . fromShort -- | Errors that can be thrown when evaluating a Plutus script. data EvaluationError = CekError (UPLC.CekEvaluationException PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun) -- ^ An error from the evaluator itself | DeBruijnError PLC.FreeVariableError -- ^ An error in the pre-evaluation step of converting from de-Bruijn indices | CodecError CBOR.DeserialiseFailure -- ^ A serialisation error - | UnavailableBuiltin ProtocolVersion PLC.DefaultFun | IncompatibleVersionError (PLC.Version ()) -- ^ An error indicating a version tag that we don't support -- TODO: make this error more informative when we have more information about what went wrong | CostModelParameterMismatch -- ^ An error indicating that the cost model parameters didn't match what we expected @@ -190,7 +188,6 @@ instance Pretty EvaluationError where pretty (CekError e) = prettyClassicDef e pretty (DeBruijnError e) = pretty e pretty (CodecError e) = viaShow e - pretty (UnavailableBuiltin pv f) = "The builtin" <+> pretty f <+> "is not available in protocol version" <+> pretty pv pretty (IncompatibleVersionError actual) = "This version of the Plutus Core interface does not support the version indicated by the AST:" <+> pretty actual pretty CostModelParameterMismatch = "Cost model parameters were not as we expected"