diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 7d80edec848..173b1d623cc 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -289,17 +289,17 @@ benchmark validation-full hs-source-dirs: validation other-modules: Common build-depends: - , base >=4.9 && <5 + , base >=4.9 && <5 , bytestring - , criterion >=1.5.9.0 + , criterion >=1.5.9.0 , deepseq , directory , filepath - , flat ^>=0.6 + , flat ^>=0.6 , optparse-applicative , plutus-benchmark-common - , plutus-core ^>=1.8 - , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>=1.8 + , plutus-core ^>=1.8 + , plutus-ledger-api ^>=1.8 ---------------- Cek cost model calibration ---------------- diff --git a/plutus-benchmark/validation/BenchCek.hs b/plutus-benchmark/validation/BenchCek.hs index 5f48269ee8c..a6ae5bd46ff 100644 --- a/plutus-benchmark/validation/BenchCek.hs +++ b/plutus-benchmark/validation/BenchCek.hs @@ -18,10 +18,11 @@ import UntypedPlutusCore as UPLC -} main :: IO () main = do - evalCtx <- evaluate (force mkEvalCtx) + evalCtx <- evaluate $ force mkEvalCtx let mkCekBM file program = - -- don't count the undebruijn . unflat cost - -- `force` to try to ensure that deserialiation is not included in benchmarking time. - let !nterm = force (toNamedDeBruijnTerm $ UPLC._progTerm $ unsafeUnflat file program) - in whnf (evaluateCekLikeInProd evalCtx) nterm + -- don't count the undebruijn . unflat cost + -- `force` to try to ensure that deserialiation is not included in benchmarking time. + let !benchTerm = force . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program + eval = either (error . show) (\_ -> ()) . evaluateCekLikeInProd evalCtx + in whnf eval benchTerm benchWith mkCekBM diff --git a/plutus-benchmark/validation/BenchFull.hs b/plutus-benchmark/validation/BenchFull.hs index a2a76037f55..a0dd8401bc2 100644 --- a/plutus-benchmark/validation/BenchFull.hs +++ b/plutus-benchmark/validation/BenchFull.hs @@ -2,15 +2,14 @@ module Main where import PlutusCore.Evaluation.Machine.ExBudget -import PlutusLedgerApi.Test.EvaluationContext (evalCtxForTesting) import PlutusLedgerApi.V1 import UntypedPlutusCore qualified as UPLC import Common import Control.DeepSeq (force) +import Control.Exception import Criterion import Data.ByteString as BS -import Data.Either {-| for each data/*.flat validation script, it benchmarks @@ -22,36 +21,29 @@ the whole time taken from script deserialization to script execution result. `cabal bench -- plutus-benchmark:validation-full --benchmark-options crowdfunding`. -} main :: IO () -main = benchWith mkFullBM - where - mkFullBM :: FilePath -> BS.ByteString -> Benchmarkable - mkFullBM file bsFlat = - let - body :: Term - (UPLC.Program _ v body) = unsafeUnflat file bsFlat - - -- We make some effort to mimic what happens on-chain, including the provision of the - -- script arguments. However, the inputs we have are *fully applied*. So we try and - -- reverse that by stripping off the arguments here. - -- Conveniently, we know that they will be Data constants. - -- Annoyingly we can't just assume it's the first 3 arguments, since some - -- of them are policy scripts with only 2. - (term, args) = peelDataArguments body - - -- strictify and "short" the result cbor to create a real `SerialisedScript` - !(benchScript :: SerialisedScript) = force (serialiseUPLC $ UPLC.Program () v term) - - in whnf (\ script -> - (isRight $ snd $ evaluateScriptRestricting +main = do + evalCtx <- evaluate $ force mkEvalCtx + let mkFullBM :: FilePath -> BS.ByteString -> Benchmarkable + mkFullBM file bsFlat = + let UPLC.Program () ver body = unsafeUnflat file bsFlat + -- We make some effort to mimic what happens on-chain, including the provision of + -- the script arguments. However, the inputs we have are *fully applied*. So we try + -- and reverse that by stripping off the arguments here. Conveniently, we know that + -- they will be Data constants. Annoyingly we can't just assume it's the first 3 + -- arguments, since some of them are policy scripts with only 2. + (term, args) = peelDataArguments body + -- strictify and "short" the result cbor to create a real `SerialisedScript` + !benchScript = force . serialiseUPLC $ UPLC.Program () ver term + eval script = + either (error . show) (\_ -> ()) . snd $ evaluateScriptRestricting (ProtocolVersion 6 0) -- no logs Quiet - evalCtxForTesting + evalCtx -- uses restricting(enormous) instead of counting to include the periodic -- budget-overspent check (unExRestrictingBudget enormousBudget) script - args) - || error "script failed to run" - ) - benchScript + args + in whnf eval benchScript + benchWith mkFullBM