Generate and use static .flat files for Marlowe benchmark

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

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.

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,34 +45,36 @@ import PlutusCore.Executable.Types
   , PrintMode (Readable)
   , UplcProg
   )
+import PlutusCore.Flat (flat, unflat)
 import PlutusCore.MkPlc (mkConstant)
 import PlutusLedgerApi.Common.Versions
 import PlutusLedgerApi.V2
 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 ()

plutus-benchmark/marlowe/test/Spec.hs

@@ -10,77 +10,57 @@ 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 $
     testGroup
       "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]
       ]

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 -----------------------