Add tasty-papi benchmarking

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
 

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

plutus-benchmark/validation/bench/BenchCekPAPI.hs

@@ -0,0 +1,54 @@
+{- | Validation benchmarks for the CEK machine. -}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Main where
+
+import Common
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Data.Proxy (Proxy (..))
+import PlutusBenchmark.Common (BenchmarkClass (..), toNamedDeBruijnTerm)
+import PlutusCore.Default (BuiltinSemanticsVariant (DefaultFunSemanticsVariantA))
+import PlutusLedgerApi.Common (PlutusLedgerLanguage (PlutusV1))
+import System.Directory (listDirectory)
+import System.IO.Unsafe (unsafePerformIO)
+import Test.Tasty qualified as T
+import Test.Tasty.Ingredients (Ingredient)
+import Test.Tasty.Options (OptionDescription (..))
+import Test.Tasty.PAPI qualified as PAPI
+import UntypedPlutusCore as UPLC
+
+-- | Benchmark instance for tasty-papi benchmarks
+-- Orphan instance for now, since the build 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 = T.withResource
+    (res >>= evaluate . force)
+    (const $ pure ())
+    (f . unsafePerformIO)
+  bench = PAPI.bench
+
+  type Options PAPI.Benchmarkable = [Ingredient]
+  runWithOptions options = T.defaultMainWithIngredients options . T.testGroup "All"
+
+--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 = T.includingOptions customOpts : PAPI.benchIngredients
+
+      mkCekBM file program =
+          benchTermCek evalCtx . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program
+      benchmarks = T.askOption $
+        \(MkQuickFlag isQuick) -> T.testGroup "All" $
+          mkBMs mkCekBM scriptDirectory (prepareFilePaths isQuick files)
+  T.defaultMainWithIngredients ingredients benchmarks

plutus-benchmark/validation/bench/Common.hs

@@ -1,31 +1,38 @@
 -- editorconfig-checker-disable-file
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
 module Common (
-    benchWith
+      benchWith
+    , mkBMs
+    , prepareFilePaths
+    , getScriptDirectory
+    , QuickFlag(..)
     , unsafeUnflat
     , mkEvalCtx
     , benchTermCek
     , peelDataArguments
     , 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
 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
@@ -83,7 +90,6 @@ unsafeUnflat file contents =
         Right (UPLC.UnrestrictedProgram prog) -> prog
 
 ----------------------- Main -----------------------
-
 -- Extend the options to include `--quick`: see eg https://github.com/haskell/criterion/pull/206
 data BenchOptions = BenchOptions
   { quick        :: Bool
@@ -102,28 +108,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 ()