diff --git a/plutus-benchmark/marlowe/bench/Shared.hs b/plutus-benchmark/marlowe/bench/Shared.hs index 19596826622..e210f5e61b0 100644 --- a/plutus-benchmark/marlowe/bench/Shared.hs +++ b/plutus-benchmark/marlowe/bench/Shared.hs @@ -3,21 +3,20 @@ module Shared where import Criterion.Main (Benchmark, Benchmarkable, bench, bgroup, defaultMainWith) -import PlutusBenchmark.Common (Program, getConfig) +import PlutusBenchmark.Common (Program, getConfig, getDataDir) import PlutusBenchmark.Marlowe.BenchUtil ( benchmarkToUPLC + , readFlat , rolePayoutBenchmarks , semanticsBenchmarks ) -import PlutusBenchmark.Marlowe.Scripts.RolePayout (rolePayoutValidator) -import PlutusBenchmark.Marlowe.Scripts.Semantics (marloweValidator) import PlutusBenchmark.Marlowe.Types qualified as M import PlutusLedgerApi.V2 (scriptContextTxInfo, txInfoId) -import PlutusTx.Code (CompiledCode) +import System.FilePath mkBenchmarkable :: (Program -> Benchmarkable) - -> CompiledCode a + -> Program -> M.Benchmark -> (String, Benchmarkable) mkBenchmarkable benchmarker validator bm@M.Benchmark {..} = @@ -26,10 +25,14 @@ mkBenchmarkable benchmarker validator bm@M.Benchmark {..} = runBenchmarks :: (Program -> Benchmarkable) -> IO () runBenchmarks benchmarker = do + dir <- getDataDir + -- Read the semantics benchmark files. + marloweValidator <- readFlat $ dir "marlowe/scripts/semantics/validator/sop.flat" semanticsMBench <- either error id <$> semanticsBenchmarks -- Read the role payout benchmark files. + rolePayoutValidator <- readFlat $ dir "marlowe/scripts/rolepayout/validator/sop.flat" rolePayoutMBench <- either error id <$> rolePayoutBenchmarks let diff --git a/plutus-benchmark/marlowe/exe/Main.hs b/plutus-benchmark/marlowe/exe/Main.hs index 17ff8798332..be0a22d8755 100644 --- a/plutus-benchmark/marlowe/exe/Main.hs +++ b/plutus-benchmark/marlowe/exe/Main.hs @@ -5,21 +5,35 @@ module Main (main) where import Cardano.Binary (serialize') import Data.ByteString qualified as BS (writeFile) import Data.ByteString.Base16 qualified as B16 (encode) +import Data.Foldable +import Data.Functor (void) import Data.List (intercalate) import PlutusBenchmark.Common (getDataDir) import PlutusBenchmark.Marlowe.BenchUtil ( rolePayoutBenchmarks , semanticsBenchmarks , tabulateResults + , writeFlat , writeFlatUPLCs ) import PlutusBenchmark.Marlowe.RolePayout qualified as RolePayout +import PlutusBenchmark.Marlowe.Scripts.Data.RolePayout qualified as DataRolePayout (rolePayoutValidator) +import PlutusBenchmark.Marlowe.Scripts.Data.Semantics qualified as DataSemantics (marloweValidator) +import PlutusBenchmark.Marlowe.Scripts.RolePayout qualified as SOPRolePayout (rolePayoutValidator) +import PlutusBenchmark.Marlowe.Scripts.Semantics qualified as SOPSemantics (marloweValidator) import PlutusBenchmark.Marlowe.Semantics qualified as Semantics import PlutusLedgerApi.V2 (ScriptHash, SerialisedScript) +import PlutusTx.Code (getPlc) import System.FilePath (normalise, ()) -{-| Run the benchmarks and export information about -the validators and the benchmarking results. -} +{- +Generates .flat files of the compiled marlowe validators. + +Additionally: +- Generates .flat files of validators applied to a all benchmark arguments +- Saves the validators to .plutus files in base-16 encoded CBOR format +- Writes .tsv files with tables of the reference costs +-} main :: IO () main = do dir <- normalise <$> getDataDir @@ -32,7 +46,20 @@ main = do rolePayoutValidatorExportDir = dir "marlowe/exe/marlowe-rolepayout" rolePayoutValidatorResults = dir "marlowe/exe/marlowe-rolepayout.tsv" - -- Read the semantics benchmarks. + -- Write .flat files for validators + let + vs = + [ (semanticsUplcDir "validator/sop.flat", SOPSemantics.marloweValidator) + , (semanticsUplcDir "validator/data.flat", DataSemantics.marloweValidator) + , (rolePayoutUplcDir "validator/sop.flat", SOPRolePayout.rolePayoutValidator) + , (rolePayoutUplcDir "validator/data.flat", DataRolePayout.rolePayoutValidator) + ] + + for_ vs $ \(path, validator) -> do + putStrLn $ "Writing " <> path + writeFlat path (void . getPlc $ validator) + + -- Read the benchmark arguments for semantics validator benchmarks <- either error id <$> semanticsBenchmarks -- Write the tabulation of semantics benchmark results. diff --git a/plutus-benchmark/marlowe/scripts/rolepayout/validator/data.flat b/plutus-benchmark/marlowe/scripts/rolepayout/validator/data.flat new file mode 100644 index 00000000000..73f81471dc6 Binary files /dev/null and b/plutus-benchmark/marlowe/scripts/rolepayout/validator/data.flat differ diff --git a/plutus-benchmark/marlowe/scripts/rolepayout/validator/sop.flat b/plutus-benchmark/marlowe/scripts/rolepayout/validator/sop.flat new file mode 100644 index 00000000000..531b9dcba1b Binary files /dev/null and b/plutus-benchmark/marlowe/scripts/rolepayout/validator/sop.flat differ diff --git a/plutus-benchmark/marlowe/scripts/semantics/validator/data.flat b/plutus-benchmark/marlowe/scripts/semantics/validator/data.flat new file mode 100644 index 00000000000..c932adb2497 Binary files /dev/null and b/plutus-benchmark/marlowe/scripts/semantics/validator/data.flat differ diff --git a/plutus-benchmark/marlowe/scripts/semantics/validator/sop.flat b/plutus-benchmark/marlowe/scripts/semantics/validator/sop.flat new file mode 100644 index 00000000000..03135f16313 Binary files /dev/null and b/plutus-benchmark/marlowe/scripts/semantics/validator/sop.flat differ diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs index 840ad3bd30c..eee8f37f4c1 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs @@ -10,6 +10,8 @@ module PlutusBenchmark.Marlowe.BenchUtil , printBenchmark , printResult , tabulateResults + , readFlat + , writeFlat , writeFlatUPLC , writeFlatUPLCs , updateScriptHash @@ -22,7 +24,8 @@ import Control.Monad (void) import Control.Monad.Except (runExcept) import Control.Monad.Writer (runWriterT) import Data.Bifunctor (bimap, second) -import Data.ByteString.Lazy qualified as LBS (readFile) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS import Data.Either.Extras (unsafeFromEither) import Data.Int (Int64) import Data.List (isSuffixOf, sort) @@ -42,6 +45,7 @@ import PlutusCore.Executable.Types , PrintMode (Readable) , UplcProg ) +import PlutusCore.Flat (flat, unflat) import PlutusCore.MkPlc (mkConstant) import PlutusLedgerApi.Common.Versions import PlutusLedgerApi.V2 @@ -49,27 +53,28 @@ import PlutusPrelude ((.*)) import PlutusTx.Code (CompiledCode, getPlc) import System.Directory (listDirectory) import System.FilePath ((<.>), ()) -import UntypedPlutusCore (NamedDeBruijn, Program (..), applyProgram) -import UntypedPlutusCore.Core.Type qualified as UPLC +import UntypedPlutusCore (NamedDeBruijn, applyProgram) +import UntypedPlutusCore qualified as UPLC + +type Program a = UPLC.Program NamedDeBruijn PLC.DefaultUni PLC.DefaultFun a -- | Turn a `PlutusBenchmark.Marlowe.Types.Benchmark` to a UPLC program. benchmarkToUPLC - :: CompiledCode a + :: Program () -- ^ semantics or role payout validator. -> M.Benchmark {-^ `PlutusBenchmark.Marlowe.Types.Benchmark`, benchmarking type used by the executable, it includes benchmarking results along with script info. -} - -> UPLC.Program NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + -> Program () -- ^ A named DeBruijn program, for turning to `Benchmarkable`. benchmarkToUPLC validator M.Benchmark {..} = foldl1 (unsafeFromEither .* applyProgram) $ - void prog : [datum, redeemer, context] + validator : [datum, redeemer, context] where wrap = UPLC.Program () (UPLC.Version 1 0 0) datum = wrap $ mkConstant () bDatum redeemer = wrap $ mkConstant () bRedeemer context = wrap $ mkConstant () $ toData bScriptContext - prog = getPlc validator -- | Read all of the benchmarking cases for a particular validator. readBenchmarks :: FilePath -> IO (Either String [Benchmark]) @@ -80,6 +85,16 @@ readBenchmarks subfolder = do <$> listDirectory folder sequence <$> mapM readBenchmark (sort files) +readFlat :: FilePath -> IO (Program ()) +readFlat path = do + contents <- BS.readFile path + case unflat contents of + Left e -> errorWithoutStackTrace $ "Flat deserialisation failure for " ++ path ++ ": " ++ show e + Right (UPLC.UnrestrictedProgram prog) -> return prog + +writeFlat :: FilePath -> Program () -> IO () +writeFlat path = BS.writeFile path . flat . UPLC.UnrestrictedProgram + -- | Read a benchmarking file. readBenchmark :: FilePath -> IO (Either String Benchmark) readBenchmark filename = do @@ -251,7 +266,7 @@ writeFlatUPLCs writer benchmarks folder = writeFlatUPLC :: CompiledCode a -> FilePath -> Benchmark -> IO () writeFlatUPLC validator filename Benchmark {..} = let - wrap = Program () (Version 1 0 0) + wrap = UPLC.Program () (Version 1 0 0) datum = wrap $ mkConstant () bDatum :: UplcProg () redeemer = wrap $ mkConstant () bRedeemer :: UplcProg () context = wrap $ mkConstant () $ toData bScriptContext :: UplcProg () diff --git a/plutus-benchmark/marlowe/test/Spec.hs b/plutus-benchmark/marlowe/test/Spec.hs index e9e8093594a..122d36b1dca 100644 --- a/plutus-benchmark/marlowe/test/Spec.hs +++ b/plutus-benchmark/marlowe/test/Spec.hs @@ -10,62 +10,42 @@ import Lib qualified import Main.Utf8 (withUtf8) import PlutusBenchmark.Common (checkGoldenFileExists) import PlutusBenchmark.Marlowe.BenchUtil - ( benchmarkToUPLC - , rolePayoutBenchmarks - , semanticsBenchmarks - ) -import PlutusBenchmark.Marlowe.Scripts.Data.RolePayout qualified as Data (rolePayoutValidator) -import PlutusBenchmark.Marlowe.Scripts.Data.Semantics qualified as Data (marloweValidator) -import PlutusBenchmark.Marlowe.Scripts.RolePayout qualified as SOP (rolePayoutValidator) -import PlutusBenchmark.Marlowe.Scripts.Semantics qualified as SOP (marloweValidator) import PlutusLedgerApi.V3 (ExCPU (..), ExMemory (..)) import System.FilePath (()) import System.IO (hPutStrLn) import Test.Tasty (defaultMain, testGroup) -import UntypedPlutusCore.AstSize qualified as UPLC +import UntypedPlutusCore.AstSize (AstSize (..)) main :: IO () main = withUtf8 $ do let dir = "marlowe" "test" + scriptDir = "marlowe" "scripts" goldenFile = dir "budgets.golden.tsv" goldenFileData = dir "data.budgets.golden.tsv" actualFile = dir "budgets.actual.tsv" actualFileData = dir "data.budgets.actual.tsv" checkGoldenFileExists goldenFile -- See Note [Paths to golden files] + let + benchSOP = + [ (scriptDir "semantics/validator/sop.flat", semanticsBenchmarks) + , (scriptDir "rolepayout/validator/sop.flat", rolePayoutBenchmarks) + ] + benchData = + [ (scriptDir "semantics/validator/data.flat", semanticsBenchmarks) + , (scriptDir "rolepayout/validator/data.flat", rolePayoutBenchmarks) + ] - -- Measure ExCPU, ExMemory, and UPLC.AstSize for each "semantics" benchmark - semanticsMeasures <- - semanticsBenchmarks >>= \case - Left err -> fail $ "Error generating semantics benchmarks: " <> show err - Right semantics -> - traverse - Lib.measureProgram - [benchmarkToUPLC SOP.marloweValidator bench | bench <- semantics] - - dataSemanticsMeasures <- - semanticsBenchmarks >>= \case - Left err -> fail $ "Error generating semantics benchmarks: " <> show err - Right semantics -> - traverse - Lib.measureProgram - [benchmarkToUPLC Data.marloweValidator bench | bench <- semantics] - - -- Measure ExCPU, ExMemory, and UPLC.AstSize for each "role payout" benchmark - rolePayoutMeasures <- - rolePayoutBenchmarks >>= \case - Left err -> fail $ "Error generating role payout benchmarks: " <> show err - Right rolePayout -> - traverse - Lib.measureProgram - [benchmarkToUPLC SOP.rolePayoutValidator bench | bench <- rolePayout] + measure (validatorPath, getCases) = do + validator <- readFlat validatorPath + getCases >>= \case + Left err -> fail $ "Error generating benchmarks: " <> show err + Right cases -> + traverse + Lib.measureProgram + [benchmarkToUPLC validator bench | bench <- cases] - dataRolePayoutMeasures <- - rolePayoutBenchmarks >>= \case - Left err -> fail $ "Error generating role payout benchmarks: " <> show err - Right rolePayout -> - traverse - Lib.measureProgram - [benchmarkToUPLC Data.rolePayoutValidator bench | bench <- rolePayout] + measuresSOP <- mapM measure benchSOP + measuresData <- mapM measure benchData -- Write the measures to the actual file defaultMain $ @@ -73,14 +53,14 @@ main = withUtf8 $ do "Marlowe" [ Lib.goldenUplcMeasurements "budgets" goldenFile actualFile \writeHandle -> for_ - (semanticsMeasures <> rolePayoutMeasures) - \(ExCPU cpu, ExMemory mem, UPLC.AstSize size) -> + (mconcat measuresSOP) + \(ExCPU cpu, ExMemory mem, AstSize size) -> hPutStrLn writeHandle $ List.intercalate "\t" [show cpu, show mem, show size] , Lib.goldenUplcMeasurements "data-budgets" goldenFileData actualFileData \writeHandle -> for_ - (dataSemanticsMeasures <> dataRolePayoutMeasures) - \(ExCPU cpu, ExMemory mem, UPLC.AstSize size) -> + (mconcat measuresData) + \(ExCPU cpu, ExMemory mem, AstSize size) -> hPutStrLn writeHandle $ List.intercalate "\t" [show cpu, show mem, show size] ] diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index f00e7de47ab..863aa78620f 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -19,7 +19,9 @@ data-files: common/templates/*.tpl force-delay/data/*.flat marlowe/scripts/rolepayout/*.benchmark + marlowe/scripts/rolepayout/validator/*.flat marlowe/scripts/semantics/*.benchmark + marlowe/scripts/semantics/validator/*.flat validation/data/*.flat source-repository head @@ -602,6 +604,7 @@ library marlowe-internal , newtype-generics , plutus-benchmark-common , plutus-core ^>=1.60 + , plutus-core:flat , plutus-ledger-api ^>=1.60 , plutus-ledger-api:plutus-execlib , plutus-tx ^>=1.60 @@ -639,10 +642,10 @@ benchmark marlowe build-depends: , base >=4.9 && <5 , criterion + , filepath , marlowe-internal , plutus-benchmark-common , plutus-ledger-api ^>=1.60 - , plutus-tx ^>=1.60 test-suite plutus-benchmark-marlowe-tests import: lang, ghc-version-support, os-support @@ -718,10 +721,10 @@ benchmark marlowe-agda-cek , agda-internal , base >=4.9 && <5 , criterion + , filepath , marlowe-internal , plutus-benchmark-common , plutus-ledger-api ^>=1.60 - , plutus-tx ^>=1.60 -------------------- bitwise -----------------------