diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 2a58f44dc6d..dd172ce6239 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) @@ -62,6 +67,29 @@ import Test.Tasty import Test.Tasty.Golden 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 + {- | 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 +99,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 @@ -135,12 +163,12 @@ evaluateCekForBench -> () evaluateCekForBench evalCtx = either (error . show) (\_ -> ()) . evaluateCekLikeInProd evalCtx -benchTermCek :: LedgerApi.EvaluationContext -> Term -> Benchmarkable +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 :: BenchmarkClass a => LedgerApi.EvaluationContext -> Program -> a benchProgramCek evalCtx (UPLC.Program _ _ term) = benchTermCek evalCtx term diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 668f5858a06..5d2c36c65ac 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -273,6 +273,29 @@ 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 + , deepseq + , 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..f41bae3c035 --- /dev/null +++ b/plutus-benchmark/validation/bench/BenchCekPAPI.hs @@ -0,0 +1,32 @@ +{- | 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 + +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..67cc9871f8a 100644 --- a/plutus-benchmark/validation/bench/Common.hs +++ b/plutus-benchmark/validation/bench/Common.hs @@ -1,7 +1,14 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + module Common ( - benchWith + benchWith + , mkBMs + , prepareFilePaths + , getScriptDirectory + , QuickFlag(..) , unsafeUnflat , mkEvalCtx , benchTermCek @@ -9,16 +16,18 @@ 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 Control.DeepSeq (force) +import Control.Exception (evaluate) +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 +35,11 @@ import Data.List (isPrefixOf) import Flat import System.Directory (listDirectory) import System.FilePath +import System.IO.Unsafe (unsafePerformIO) +import Test.Tasty (defaultMainWithIngredients, testGroup, withResource) +import Test.Tasty.Ingredients (Ingredient) +import Test.Tasty.Options (IsOption (..), safeRead) +import Test.Tasty.PAPI qualified as PAPI {- | Benchmarks based on validations obtained using plutus-use-cases:plutus-use-cases-scripts, which runs various contracts on the @@ -83,6 +97,21 @@ unsafeUnflat file contents = Right (UPLC.UnrestrictedProgram prog) -> prog ----------------------- Main ----------------------- +-- | Benchmark instance for tasty-papi benchmarks +-- Orphan instance for now, since the build still fails +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" -- Extend the options to include `--quick`: see eg https://github.com/haskell/criterion/pull/206 data BenchOptions = BenchOptions @@ -102,28 +131,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] -> [Benchmark a] +mkBMs act dir files = map mkScriptBM files + where + mkScriptBM :: FilePath -> 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 ()