PLT-7583 Validator optimizations

changelog.d/20231209_094720_brian.bush_PLT_7583.md

@@ -0,0 +1,4 @@
+### Changed
+
+- The `Contract` and `Action` types now use `PlutusTx.asData`.
+- The `PlutusTx.geq` comparison function has been specialized.

marlowe-plutus/app/Benchmark/Marlowe.hs

@@ -24,7 +24,7 @@ import Control.Monad.Writer (runWriterT)
 import Data.Bifunctor (bimap)
 import Data.Either.Extras (unsafeFromEither)
 import Data.List (isSuffixOf)
-import Language.Marlowe.Core.V1.Semantics (MarloweData)
+import Language.Marlowe.Plutus.Semantics (MarloweData)
 import Language.Marlowe.Scripts.Types (MarloweInput)
 import Paths_marlowe_plutus (getDataDir)
 import PlutusCore.Executable.AstIO (fromNamedDeBruijnUPLC)

marlowe-plutus/app/Benchmark/Marlowe/Semantics.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -24,7 +25,7 @@ import Benchmark.Marlowe.Util (
   updateScriptHash,
  )
 import Data.Bifunctor (second)
-import Language.Marlowe.Plutus.Semantics (
+import Language.Marlowe.Plutus.Script (
   marloweValidator,
   marloweValidatorBytes,
   marloweValidatorHash,

marlowe-plutus/app/Benchmark/Marlowe/Semantics/Pretty.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Benchmark.Marlowe.Semantics.Pretty (
+  writeBenchmarks,
+  writeBenchmark,
+) where
+
+import Benchmark.Marlowe.Types
+import Control.Applicative ((<|>))
+import Language.Marlowe.Core.V1.Semantics (MarloweData)
+import Language.Marlowe.Scripts.Types (MarloweInput, MarloweTxInput (..))
+import PlutusLedgerApi.V1.Value (flattenValue)
+import PlutusLedgerApi.V2
+import System.Directory
+import System.FilePath
+
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import qualified Data.Yaml as Y
+import qualified PlutusTx.AssocMap as AM
+
+writeBenchmarks
+  :: FilePath
+  -> [Benchmark]
+  -> IO ()
+writeBenchmarks folder benchmarks =
+  do
+    createDirectoryIfMissing True folder
+    sequence_
+      [ writeBenchmark (folder </> show txId <.> "yaml") benchmark
+      | benchmark <- benchmarks
+      , let txId = txInfoId . scriptContextTxInfo $ bScriptContext benchmark
+      ]
+
+writeBenchmark
+  :: FilePath
+  -> Benchmark
+  -> IO ()
+writeBenchmark filename Benchmark{bScriptContext = ScriptContext{scriptContextTxInfo = TxInfo{..}}, ..} =
+  let marloweTxInputToJSON (Input content) =
+        A.object
+          [ "input" A..= content
+          ]
+      marloweTxInputToJSON (MerkleizedTxInput content hash) =
+        A.object
+          [ "input" A..= content
+          , "continuation" A..= show hash
+          ]
+      addressToJSON Address{..} =
+        A.object
+          [ "payment" A..= show addressCredential
+          , "staking" A..= show addressStakingCredential
+          ]
+      valueToJSON v =
+        [ A.object
+          [ "currencySymbol" A..= show c
+          , "tokenName" A..= (tail . init . show) t
+          , "quantity" A..= a
+          ]
+        | (c, t, a) <- flattenValue v
+        ]
+      txOutputToJSON TxOut{..} =
+        A.object
+          [ "address" A..= addressToJSON txOutAddress
+          , "value" A..= valueToJSON txOutValue
+          , "datum" A..= show txOutDatum
+          ]
+      txInputToJSON TxInInfo{..} =
+        A.object
+          [ "txOutRef" A..= (show (txOutRefId txInInfoOutRef) <> "#" <> show (txOutRefIdx txInInfoOutRef))
+          , "txOut" A..= txOutputToJSON txInInfoResolved
+          ]
+   in BS8.writeFile filename
+        . Y.encode
+        . A.object
+        $ [ "txId" A..= show txInfoId
+          , "inputs" A..= fmap txInputToJSON txInfoInputs
+          , "outputs" A..= fmap txOutputToJSON txInfoOutputs
+          , "validityInterval"
+              A..= case txInfoValidRange of
+                Interval (LowerBound (Finite (POSIXTime l)) _) (UpperBound (Finite (POSIXTime h)) _) ->
+                  pure $
+                    A.object
+                      [ "invalidBefore" A..= l
+                      , "invalidHereafter" A..= h
+                      ]
+                _ -> Nothing
+          , "redeemer" A..= fmap (fmap marloweTxInputToJSON) (fromData bRedeemer :: Maybe MarloweInput)
+          , "datums"
+              A..= M.fromList
+                [ ( T.pack $ show dh
+                  , marloweData <|> payoutData <|> pure (A.toJSON $ show d)
+                  )
+                | (dh, Datum d) <- AM.toList txInfoData
+                , let marloweData = fmap A.toJSON (fromBuiltinData d :: Maybe MarloweData)
+                , let payoutData =
+                        (\(c, t) -> A.object ["currencySymbol" A..= show c, "tokenName" A..= (tail . init . show) t])
+                          <$> (fromBuiltinData d :: Maybe (CurrencySymbol, TokenName))
+                ]
+          ]

marlowe-plutus/app/Main.hs

@@ -26,6 +26,7 @@ import qualified Benchmark.Marlowe.Semantics as Semantics (
   validatorHash,
   writeUPLC,
  )
+import qualified Benchmark.Marlowe.Semantics.Pretty as Semantics (writeBenchmarks)
 import qualified Data.ByteString as BS (writeFile)
 import qualified Data.ByteString.Base16 as B16 (encode)
 
@@ -53,12 +54,13 @@ main =
     -- Print the semantics validator, and write the plutus file.
     printValidator
       "Open roles"
-      (dir </> "marlowe-openroles")
+      (dir </> "open-role")
       openRoleValidatorHash
       openRoleValidatorBytes
 
     -- Read the semantics benchmarks.
     benchmarks <- either error id <$> Semantics.benchmarks
+    Semantics.writeBenchmarks (dir </> "benchmarks" </> "semantics") benchmarks
 
     -- Write the tabulation of semantics benchmark results.
     writeFile (out </> "marlowe-semantics.tsv")

marlowe-plutus/charli3/Language/Marlowe/Plutus/Charli3.hs

@@ -36,7 +36,7 @@ module Language.Marlowe.Plutus.Charli3 (
 ) where
 
 import Language.Marlowe.Plutus (hashScript)
-import Language.Marlowe.Plutus.Semantics (marloweValidatorHash)
+import Language.Marlowe.Plutus.Script (marloweValidatorHash)
 import PlutusCore.Version (plcVersion100)
 import PlutusLedgerApi.V1.Address (scriptHashAddress)
 import PlutusLedgerApi.V1.Value (adaSymbol, getValue, valueOf)
@@ -58,8 +58,8 @@ import PlutusTx (CompiledCode)
 
 import PlutusTx.Prelude as PlutusTxPrelude
 
-import qualified Language.Marlowe.Core.V1.Semantics.Types as V1
-import qualified Language.Marlowe.Scripts.Types as V1.Scripts
+import qualified Language.Marlowe.Plutus.Script.Types as V1.Scripts
+import qualified Language.Marlowe.Plutus.Semantics.Types as V1
 import qualified OracleFeed as C3
 import qualified PlutusLedgerApi.V2 as PV2
 import qualified PlutusTx

marlowe-plutus/charli3/Main.hs

@@ -11,8 +11,8 @@ import Cardano.Binary (serialize')
 
 import qualified Data.ByteString as BS (writeFile)
 import qualified Data.ByteString.Base16 as B16 (encode)
-import qualified Language.Marlowe.Core.V1.Semantics.Types as V1
 import qualified Language.Marlowe.Plutus.Charli3 as Charli3 (validatorBytes, validatorHash)
+import qualified Language.Marlowe.Plutus.Semantics.Types as V1
 import qualified Options.Applicative as O
 
 -- | The command-line arguments.

marlowe-plutus/create-flamegraphs.sh

@@ -0,0 +1,43 @@
+#!/usr/bin/env nix-shell
+#! nix-shell -i bash -p flamegraph
+# shellcheck shell=bash
+
+set -eo pipefail
+
+UPLC="$(nix build 'github:input-output-hk/plutus?ref=1.17.0.0#uplc' --no-link --print-out-paths)/bin/uplc"
+TRACETOSTACKS="$(nix build 'github:input-output-hk/plutus?ref=1.17.0.0#traceToStacks' --no-link --print-out-paths)/bin/traceToStacks"
+
+for f in out/semantics/*-uplc.flat
+do
+
+  t=$(basename "${f%%-uplc.flat}")
+  echo "Tx $t"
+  l="${f%%.flat}.log"
+  s="${f%%.flat}.steps.svg"
+  m="${f%%.flat}.memory.svg"
+
+  "$UPLC" evaluate \
+      --input "$f" \
+      --input-format flat-namedDeBruijn \
+      --trace-mode LogsWithBudgets \
+      --output "$l"
+
+  "$TRACETOSTACKS" --file "$l" --column 1 \
+  | flamegraph.pl \
+  > "$s"
+
+  sed -e '/^<text id="title"/s/>.*</>Steps in Tx '"$t"'</' \
+      -e '3s/width="[^"]*"/width="100%"/' \
+      -e '3s/height="[^"]*"/height="100%"/' \
+      -i "$s"
+
+  "$TRACETOSTACKS" --file "$l" --column 2 \
+  | flamegraph.pl \
+  > "$m"
+
+  sed -e '/^<text id="title"/s/>.*</>Memory in Tx '"$t"'</' \
+      -e '3s/width="[^"]*"/width="100%"/' \
+      -e '3s/height="[^"]*"/height="100%"/' \
+      -i "$m"
+
+done

marlowe-plutus/marlowe-plutus.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.4
 name:          marlowe-plutus
-version:       0.1.1.0
+version:       0.1.2.0
 license:       Apache-2.0
 build-type:    Simple
 maintainer:    brian.bush@iohk.io
@@ -34,48 +34,56 @@ flag trace-plutus
   default:     False
   manual:      True
 
+flag profile-plutus
+  description: Enable Plutus profiling for Marlowe validators.
+  default:     False
+  manual:      True
+
 flag check-preconditions
   description:
     Validator checks whether preconditions are satisfied for the Marlowe state.
 
   default:     True
-  manual:      False
+  manual:      True
 
 flag check-positive-balances
   description:
     Validator checks whether any account balances are non-positive in the Marlowe state.
 
   default:     True
-  manual:      False
+  manual:      True
 
 flag check-duplicate-accounts
   description:
     Validator checks whether any accounts are duplicated in the Marlowe state.
 
   default:     True
-  manual:      False
+  manual:      True
 
 flag check-duplicate-choices
   description:
     Validator checks whether any choices are duplicated in the Marlowe state.
 
   default:     True
-  manual:      False
+  manual:      True
 
 flag check-duplicate-bindings
   description:
     Validator checks whether any bound values are duplicated in the Marlowe state.
 
   default:     True
-  manual:      False
-
-flag plutus-asdata
-  description:
-    Experimental! Use alternative implementation relying on `PlutusTx.asData`.
+  manual:      True
 
+flag asdata-case
+  description: Use `PlutusTx.asData` for `Case`.
   default:     False
   manual:      True
 
+flag asdata-action
+  description: Use `PlutusTx.asData` for `Action`.
+  default:     True
+  manual:      True
+
 common lang
   default-language:   Haskell2010
   default-extensions:
@@ -89,18 +97,18 @@ common lang
     StandaloneDeriving
 
   ghc-options:
-    -Wall -Wnoncanonical-monad-instances -Wincomplete-uni-patterns
-    -Wincomplete-record-updates -Wredundant-constraints -Widentities
-    -Werror
+    -fforce-recomp -Wall -Wnoncanonical-monad-instances
+    -Wincomplete-uni-patterns -Wincomplete-record-updates
+    -Wredundant-constraints -Widentities -Werror
+
+  if (flag(profile-plutus) || flag(trace-plutus))
+    ghc-options: -fplugin-opt PlutusTx.Plugin:conservative-optimisation
+
+  if flag(profile-plutus)
+    ghc-options: -fplugin-opt PlutusTx.Plugin:profile-all
 
   if flag(trace-plutus)
     cpp-options: -DTRACE_PLUTUS
-    ghc-options:
-      -fforce-recomp -fplugin-opt
-      PlutusTx.Plugin:conservative-optimisation
-
-  else
-    ghc-options: -fforce-recomp -fplugin-opt PlutusTx.Plugin:remove-trace
 
   if flag(check-preconditions)
     cpp-options: -DCHECK_PRECONDITIONS
@@ -126,7 +134,6 @@ library
     , cardano-crypto-class
     , flat
     , lens
-    , marlowe-cardano ==0.2.1.0
     , newtype-generics
     , plutus-core ==1.15.0.0
     , plutus-ledger-api ==1.15.0.0
@@ -136,18 +143,21 @@ library
 
   exposed-modules:
     Language.Marlowe.Plutus
-    Language.Marlowe.Plutus.Alt.ScriptTypes
-    Language.Marlowe.Plutus.Alt.Semantics
-    Language.Marlowe.Plutus.Alt.Semantics.Types
-    Language.Marlowe.Plutus.Alt.Semantics.Types.Address
     Language.Marlowe.Plutus.OpenRoles
     Language.Marlowe.Plutus.RolePayout
     Language.Marlowe.Plutus.RoleTokens
     Language.Marlowe.Plutus.RoleTokens.Types
+    Language.Marlowe.Plutus.Script
+    Language.Marlowe.Plutus.Script.Types
     Language.Marlowe.Plutus.Semantics
+    Language.Marlowe.Plutus.Semantics.Types
+    Language.Marlowe.Plutus.Semantics.Types.Address
+
+  if flag(asdata-case)
+    cpp-options: -DASDATA_CASE
 
-  if flag(plutus-asdata)
-    cpp-options: -DPLUTUS_ASDATA
+  if flag(asdata-action)
+    cpp-options: -DASDATA_ACTION
 
 executable marlowe-validators
   import:         lang
@@ -157,11 +167,13 @@ executable marlowe-validators
     Benchmark.Marlowe
     Benchmark.Marlowe.RolePayout
     Benchmark.Marlowe.Semantics
+    Benchmark.Marlowe.Semantics.Pretty
     Benchmark.Marlowe.Types
     Benchmark.Marlowe.Util
     Paths_marlowe_plutus
 
   build-depends:
+    , aeson
     , base
     , base16-bytestring
     , bytestring
@@ -177,6 +189,7 @@ executable marlowe-validators
     , plutus-tx
     , serialise
     , text
+    , yaml
 
   ghc-options:    -threaded
 
@@ -274,7 +287,6 @@ executable marlowe-charli3
     , base16-bytestring
     , bytestring
     , cardano-binary
-    , marlowe-cardano ==0.2.1.0
     , marlowe-plutus
     , optparse-applicative
     , oracle-feed