diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 2a58f44dc6d..e081fb0ea77 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE ViewPatterns #-} {- | Miscellaneous shared code for benchmarking-related things. -} module PlutusBenchmark.Common @@ -20,6 +22,7 @@ module PlutusBenchmark.Common , mkMostRecentEvalCtx , evaluateCekLikeInProd , benchTermCek + , BenchmarkClass(..) , TestSize (..) , printHeader , printSizeStatistics @@ -47,8 +50,10 @@ import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek as Cek import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC -import Control.DeepSeq (force) -import Criterion.Main +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Criterion.Main qualified as Crit +import Criterion.Main.Options (Mode) import Criterion.Types (Config (..)) import Data.ByteString qualified as BS import Data.SatInt (fromSatInt) @@ -58,10 +63,51 @@ import System.Directory import System.FilePath import System.IO import System.IO.Temp +import System.IO.Unsafe (unsafePerformIO) import Test.Tasty import Test.Tasty.Golden +import Test.Tasty.Ingredients (Ingredient) +import Test.Tasty.PAPI qualified as PAPI import Text.Printf (hPrintf, printf) +-- | Abstract interface for benchmarks +-- We need the typeclass because tasty-papi defines a different Benchmarkable type +class BenchmarkClass a where + whnf :: (b -> c) -> b -> a + + type Benchmark a = r | r -> a + env :: NFData env => IO env -> (env -> Benchmark a) -> Benchmark a + bench :: String -> a -> Benchmark a + + type Options a = r | r -> a + runWithOptions :: Options a -> [Benchmark a] -> IO () + +-- | Instance for criterion benchmarks +instance BenchmarkClass Crit.Benchmarkable where + whnf = Crit.whnf + + type Benchmark Crit.Benchmarkable = Crit.Benchmark + env = Crit.env + bench = Crit.bench + + type Options Crit.Benchmarkable = Mode + runWithOptions = Crit.runMode + +-- | Instance for tasty-papi benchmarks +instance BenchmarkClass PAPI.Benchmarkable where + whnf = PAPI.whnf + +-- env definition is basically copypaste from tasty's source code + type Benchmark PAPI.Benchmarkable = PAPI.Benchmark + env res f = withResource + (res >>= evaluate . force) + (const $ pure ()) + (f . unsafePerformIO) + bench = PAPI.bench + + type Options PAPI.Benchmarkable = [Ingredient] + runWithOptions options = defaultMainWithIngredients options . testGroup "All" + {- | The Criterion configuration returned by `getConfig` will cause an HTML report to be generated. If run via stack/cabal this will be written to the `plutus-benchmark` directory by default. The -o option can be used to change @@ -71,7 +117,7 @@ getConfig limit = do templateDir <- getDataFileName ("common" "templates") -- Include number of iterations in HTML report let templateFile = templateDir "with-iterations" <.> "tpl" - pure $ defaultConfig { + pure $ Crit.defaultConfig { template = templateFile, reportFile = Just "report.html", timeLimit = limit @@ -134,13 +180,18 @@ evaluateCekForBench -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () -> () evaluateCekForBench evalCtx = either (error . show) (\_ -> ()) . evaluateCekLikeInProd evalCtx - -benchTermCek :: LedgerApi.EvaluationContext -> Term -> Benchmarkable +{- +benchTermCek :: LedgerApi.EvaluationContext -> Term -> Crit.Benchmarkable +benchTermCek evalCtx term = + let !term' = force term + in whnf (evaluateCekForBench evalCtx) term' +-} +benchTermCek :: BenchmarkClass a => LedgerApi.EvaluationContext -> Term -> a benchTermCek evalCtx term = let !term' = force term in whnf (evaluateCekForBench evalCtx) term' -benchProgramCek :: LedgerApi.EvaluationContext -> Program -> Benchmarkable +benchProgramCek :: LedgerApi.EvaluationContext -> Program -> Crit.Benchmarkable benchProgramCek evalCtx (UPLC.Program _ _ term) = benchTermCek evalCtx term diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 668f5858a06..21f13cb06e7 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -99,6 +99,7 @@ library plutus-benchmark-common , plutus-tx-test-util , tasty , tasty-golden + , tasty-papi , temporary ---------------- nofib ---------------- @@ -273,6 +274,28 @@ benchmark validation , plutus-core ^>=1.36 , plutus-ledger-api ^>=1.36 +---------------- validation-papi ---------------- + +benchmark validation-papi + import: lang, os-support + type: exitcode-stdio-1.0 + main-is: BenchCekPAPI.hs + hs-source-dirs: validation/bench + other-modules: Common + build-depends: + , base >=4.9 && <5 + , bytestring + , criterion >=1.5.9.0 + , directory + , filepath + , flat ^>=0.6 + , optparse-applicative + , plutus-benchmark-common + , plutus-core ^>=1.36 + , plutus-ledger-api ^>=1.36 + , tasty + , tasty-papi + ---------------- validation-decode ---------------- benchmark validation-decode diff --git a/plutus-benchmark/validation/bench/BenchCekPAPI.hs b/plutus-benchmark/validation/bench/BenchCekPAPI.hs new file mode 100644 index 00000000000..a0eda879ad6 --- /dev/null +++ b/plutus-benchmark/validation/bench/BenchCekPAPI.hs @@ -0,0 +1,39 @@ +{- | Validation benchmarks for the CEK machine. -} +{-# LANGUAGE BangPatterns #-} +module Main where + +import Common +import Control.Exception (evaluate) +import Data.Proxy (Proxy (..)) +import PlutusBenchmark.Common (toNamedDeBruijnTerm) +import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariantA)) +import PlutusLedgerApi.Common (PlutusLedgerLanguage (PlutusV1)) +import System.Directory (listDirectory) +import Test.Tasty (askOption, defaultMainWithIngredients, includingOptions, testGroup) +import Test.Tasty.Options (OptionDescription (..)) +import Test.Tasty.PAPI (benchIngredients) +import UntypedPlutusCore as UPLC + +{-| + Benchmarks only for the CEK execution time of the data/*.flat validation scripts + + Run the benchmarks. You can run groups of benchmarks by typing things like + `stack bench -- plutus-benchmark:validation --ba crowdfunding` + or + `cabal bench -- plutus-benchmark:validation --benchmark-options crowdfunding`. +-} + +main :: IO () +main = do + scriptDirectory <- getScriptDirectory + files <- listDirectory scriptDirectory + evalCtx <- evaluate $ mkEvalCtx PlutusV1 DefaultFunSemanticsVariantA + let customOpts = [Option (Proxy :: Proxy QuickFlag)] + ingredients = includingOptions customOpts : benchIngredients + + mkCekBM file program = + benchTermCek evalCtx . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program + benchmarks = askOption $ + \(MkQuickFlag isQuick) -> testGroup "All" $ + mkBMs mkCekBM scriptDirectory (prepareFilePaths isQuick files) + defaultMainWithIngredients ingredients benchmarks diff --git a/plutus-benchmark/validation/bench/Common.hs b/plutus-benchmark/validation/bench/Common.hs index 77cbeacadaf..eb5b6960fa7 100644 --- a/plutus-benchmark/validation/bench/Common.hs +++ b/plutus-benchmark/validation/bench/Common.hs @@ -1,7 +1,13 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Common ( - benchWith + benchWith + , mkBMs + , prepareFilePaths + , getScriptDirectory + , QuickFlag(..) , unsafeUnflat , mkEvalCtx , benchTermCek @@ -9,16 +15,16 @@ module Common ( , Term ) where -import PlutusBenchmark.Common (benchTermCek, getConfig, getDataDir, mkEvalCtx) +import PlutusBenchmark.Common (BenchmarkClass (..), benchTermCek, getConfig, getDataDir, mkEvalCtx) import PlutusBenchmark.NaturalSort import PlutusCore.Builtin qualified as PLC import PlutusCore.Data qualified as PLC import UntypedPlutusCore qualified as UPLC -import Criterion.Main +import Criterion.Main (runMode) import Criterion.Main.Options (Mode, parseWith) -import Criterion.Types (Config (..)) +import Criterion.Types (Benchmarkable, Config (..)) import Options.Applicative import Data.ByteString qualified as BS @@ -26,6 +32,7 @@ import Data.List (isPrefixOf) import Flat import System.Directory (listDirectory) import System.FilePath +import Test.Tasty.Options (IsOption (..), safeRead) {- | Benchmarks based on validations obtained using plutus-use-cases:plutus-use-cases-scripts, which runs various contracts on the @@ -102,28 +109,40 @@ parserInfo :: Config -> ParserInfo BenchOptions parserInfo cfg = info (helper <*> parseBenchOptions cfg) $ header "Plutus Core validation benchmark suite" +-- Ingredient for quick option +newtype QuickFlag = MkQuickFlag Bool + +instance IsOption QuickFlag where + defaultValue = MkQuickFlag False + parseValue = fmap MkQuickFlag . safeRead + optionName = pure "quick" + optionHelp = pure "Run only a small subset of the benchmarks" + +-- Make benchmarks for the given files in the directory +mkBMs :: forall a. BenchmarkClass a => (FilePath -> BS.ByteString -> a) -> FilePath -> [FilePath] -> [PlutusBenchmark.Common.Benchmark a] +mkBMs act dir files = map mkScriptBM files + where + mkScriptBM :: FilePath -> PlutusBenchmark.Common.Benchmark a + mkScriptBM file = + env (BS.readFile $ dir file) $ \(~scriptBS) -> + bench (dropExtension file) $ act file scriptBS + +prepareFilePaths :: Bool -> [FilePath] -> [FilePath] +prepareFilePaths isQuick files = if isQuick + then files1 `withAnyPrefixFrom` quickPrefixes + else files1 + where + -- naturalSort puts the filenames in a better order than Data.List.Sort + files1 = naturalSort $ filter (isExtensionOf ".flat") files -- Just in case there's anything else in the directory. + benchWith :: (FilePath -> BS.ByteString -> Benchmarkable) -> IO () benchWith act = do cfg <- getConfig 20.0 -- Run each benchmark for at least 20 seconds. Change this with -L or --timeout (longer is better). options <- execParser $ parserInfo cfg scriptDirectory <- getScriptDirectory files0 <- listDirectory scriptDirectory -- Just the filenames, not the full paths - let -- naturalSort puts the filenames in a better order than Data.List.Sort - files1 = naturalSort $ filter (isExtensionOf ".flat") files0 -- Just in case there's anything else in the directory. - files = if quick options - then files1 `withAnyPrefixFrom` quickPrefixes - else files1 - runMode (otherOptions options) $ mkBMs scriptDirectory files - where - - -- Make benchmarks for the given files in the directory - mkBMs :: FilePath -> [FilePath] -> [Benchmark] - mkBMs dir files = map (mkScriptBM dir) files - - mkScriptBM :: FilePath -> FilePath -> Benchmark - mkScriptBM dir file = - env (BS.readFile $ dir file) $ \(~scriptBS) -> - bench (dropExtension file) $ act file scriptBS + let files = prepareFilePaths (quick options) files0 + runMode (otherOptions options) $ mkBMs act scriptDirectory files type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()