Merge pull request #167 from input-output-hk/abailly-iohk/consolidate…

…-cost-computation

Consolidate cost computation in a single executable

cabal.project

@@ -21,6 +21,7 @@ package hydra-node
 
 package hydra-plutus
   tests: True
+  haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors"
 
 package hydra-tui
   tests: True
@@ -30,10 +31,11 @@ package merkle-patricia-tree
 
 package plutus-cbor
   tests: True
+  haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors"
 
 package plutus-merkle-tree
   tests: True
-
+  haddock-options: "--optghc=-fplugin-opt PlutusTx.Plugin:defer-errors"
 
 -- Always show detailed output for tests
 test-show-details: direct

hydra-node/exe/tx-cost/Main.hs

@@ -2,35 +2,73 @@
 
 import Hydra.Prelude
 
+import Cardano.Api (NetworkId (Testnet), NetworkMagic (NetworkMagic))
 import qualified Cardano.Ledger.Alonzo as Ledger.Alonzo
 import qualified Cardano.Ledger.Alonzo.Data as Ledger
 import qualified Cardano.Ledger.Alonzo.PParams as Ledger
 import qualified Cardano.Ledger.Alonzo.Scripts as Ledger
 import qualified Cardano.Ledger.Alonzo.TxBody as Ledger.Alonzo
 import qualified Cardano.Ledger.Shelley.API as Ledger
 import qualified Cardano.Ledger.Val as Ledger
-import qualified Data.Map.Strict as Map
+import Control.Exception (ErrorCall)
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import Data.Maybe (fromJust)
 import Data.Maybe.Strict (StrictMaybe (..))
 import Hydra.Chain.Direct.Tx (fanoutTx, plutusScript, policyId, scriptAddr)
+import qualified Hydra.Contract.Hash as Hash
 import qualified Hydra.Contract.Head as Head
 import Hydra.Ledger.Cardano (
+  BuildTxWith (BuildTxWith),
   CardanoTx,
+  ExecutionUnits (..),
   LedgerEra,
+  PlutusScriptV1,
+  TxOut (..),
   Utxo,
+  Utxo' (Utxo),
   adaOnly,
+  addInputs,
+  emptyTxBody,
+  fromAlonzoExUnits,
   fromLedgerTx,
   fromLedgerUtxo,
+  fromPlutusScript,
   genKeyPair,
   genOneUtxoFor,
   hashTxOuts,
+  lovelaceToTxOutValue,
+  mkDatumForTxIn,
+  mkRedeemerForTxIn,
+  mkScriptAddress,
+  mkScriptWitness,
+  mkTxOutDatum,
   simplifyUtxo,
+  toCtxUTxOTxOut,
+  unsafeBuildTransaction,
  )
 import Hydra.Ledger.Cardano.Evaluate (evaluateTx, pparams)
+import Plutus.MerkleTree (rootHash)
+import qualified Plutus.MerkleTree as MT
+import Plutus.Orphans ()
 import Plutus.V1.Ledger.Api (toBuiltin, toData)
+import qualified PlutusTx.Builtins as Plutus
+import Test.Plutus.Validator (
+  ExUnits (ExUnits),
+  defaultMaxExecutionUnits,
+  evaluateScriptExecutionUnits,
+ )
 import Test.QuickCheck (generate, vectorOf)
+import Validators (merkleTreeValidator, mtBuilderValidator)
 
 main :: IO ()
 main = do
+  costOfFanOut
+  costOfMerkleTree
+  costOfHashing
+
+costOfFanOut :: IO ()
+costOfFanOut = do
   putStrLn "Cost of running the fanout validator"
   putStrLn "# UTXO  % max Mem   % max CPU"
   forM_ [1 .. 100] $ \numElems -> do
@@ -43,7 +81,7 @@ main = do
             <> showPad 12 (100 * fromIntegral mem / maxMem)
             <> showPad 12 (100 * fromIntegral cpu / maxCpu)
       _ ->
-        fail $ "Failed to evaluate transaction with " <> show numElems <> " elements."
+        pure ()
  where
   genSomeUtxo = genKeyPair >>= fmap (fmap adaOnly) . genOneUtxoFor . fst
   Ledger.ExUnits (fromIntegral @_ @Double -> maxMem) (fromIntegral @_ @Double -> maxCpu) =
@@ -77,3 +115,103 @@ mkHeadOutput headDatum =
   headAddress = scriptAddr $ plutusScript $ Head.validatorScript policyId
   headValue = Ledger.inject (Ledger.Coin 2_000_000)
   headDatumHash = Ledger.hashData @LedgerEra <$> headDatum
+
+costOfMerkleTree :: IO ()
+costOfMerkleTree = do
+  putStrLn "Cost of on-chain Merkle-Tree"
+  forM_ ([1 .. 10] <> [20, 30 .. 100] <> [120, 140 .. 500]) $ \numElems -> do
+    utxo <- fmap Plutus.toBuiltin <$> genFakeUtxos numElems
+
+    let (memberMem, memberCpu) = executionCostForMember utxo
+        ExUnits (fromIntegral @_ @Double -> maxMem) (fromIntegral @_ @Double -> maxCpu) =
+          defaultMaxExecutionUnits
+        (builderMem, builderCpu) = executionCostForBuilder utxo
+
+    putText $
+      show numElems
+        <> "\t"
+        <> show (100 * fromIntegral (fromIntegral memberMem `div` numElems) / maxMem)
+        <> "\t"
+        <> show (100 * fromIntegral (fromIntegral memberCpu `div` numElems) / maxCpu)
+    putTextLn
+      ( "\t"
+          <> show (100 * fromIntegral builderMem / maxMem)
+          <> "\t"
+          <> show (100 * fromIntegral builderCpu / maxCpu)
+      )
+      `catch` \(_ :: ErrorCall) ->
+        -- NOTE builder validator is likely to fail and thus raise an exception at low values
+        -- of numElems, so we put 0 instead
+        putTextLn "\t0\t0"
+ where
+  -- NOTE: assume size of a UTXO is around  60 bytes
+  genFakeUtxos numElems = generate (vectorOf numElems $ BS.pack <$> vectorOf 60 arbitrary)
+
+executionCostForMember :: [Plutus.BuiltinByteString] -> (Natural, Natural)
+executionCostForMember utxo =
+  let tree = MT.fromList utxo
+      accumulateCost e (curMem, curCpu) =
+        let proof = fromJust $ MT.mkProof e tree
+            ExUnits mem cpu = evaluateScriptExecutionUnits merkleTreeValidator (e, MT.rootHash tree, proof)
+         in (mem + curMem, cpu + curCpu)
+   in foldr accumulateCost (0, 0) utxo
+
+executionCostForBuilder :: [Plutus.BuiltinByteString] -> (Natural, Natural)
+executionCostForBuilder utxo =
+  let tree = MT.fromList utxo
+      root = rootHash tree
+      ExUnits mem cpu = evaluateScriptExecutionUnits mtBuilderValidator (utxo, root)
+   in (mem, cpu)
+
+costOfHashing :: IO ()
+costOfHashing = do
+  putStrLn "Cost of on-chain Hashing"
+  for_ [0 .. 5] $ \(power :: Integer) -> do
+    let n = 8 ^ power
+        s = n `quot` 8
+    putTextLn @IO $ "    n = " <> show n <> ", s = " <> show s
+    for_ [minBound .. maxBound] $ \algorithm ->
+      do
+        let ExecutionUnits
+              { executionSteps = baseCpu
+              , executionMemory = baseMem
+              } = calculateHashExUnits n Hash.Base
+            units@ExecutionUnits
+              { executionSteps = cpu
+              , executionMemory = mem
+              } = calculateHashExUnits n algorithm
+        putTextLn $
+          "      " <> show algorithm
+            <> ": "
+            <> show units
+            <> " Δcpu="
+            <> show (toInteger cpu - toInteger baseCpu)
+            <> " Δmem="
+            <> show (toInteger mem - toInteger baseMem)
+        `catch` \(_ :: ErrorCall) ->
+          -- NOTE: evaluation can fail and raise an error if it blows up limits, simply stop there
+          pure ()
+
+calculateHashExUnits :: Int -> Hash.HashAlgorithm -> ExecutionUnits
+calculateHashExUnits n algorithm =
+  case evaluateTx tx utxo of
+    Left basicFailure ->
+      error ("Basic failure: " <> show basicFailure)
+    Right report ->
+      case Map.elems report of
+        [Right units] ->
+          fromAlonzoExUnits units
+        _ ->
+          error $ "Too many redeemers in report: " <> show report
+ where
+  tx = unsafeBuildTransaction $ emptyTxBody & addInputs [(input, witness)]
+  utxo = Utxo $ Map.singleton input output
+  input = generateWith arbitrary 42
+  output = toCtxUTxOTxOut $ TxOut address value (mkTxOutDatum datum)
+  value = lovelaceToTxOutValue 1_000_000
+  address = mkScriptAddress @PlutusScriptV1 (Testnet $ NetworkMagic 42) script
+  witness = BuildTxWith $ mkScriptWitness script (mkDatumForTxIn datum) redeemer
+  script = fromPlutusScript Hash.validatorScript
+  datum = Hash.datum $ toBuiltin bytes
+  redeemer = mkRedeemerForTxIn $ Hash.redeemer algorithm
+  bytes = fold $ replicate n ("0" :: ByteString)

plutus-merkle-tree/src/Plutus/MerkleTreeValidator.hs → hydra-node/exe/tx-cost/Validators.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-specialize #-}
 
-module Plutus.MerkleTreeValidator where
+module Validators where
 
 import PlutusTx.Prelude
 
@@ -11,22 +11,6 @@ import Plutus.MerkleTree (Hash, Proof, member)
 import qualified Plutus.MerkleTree as MT
 import qualified PlutusTx as Plutus
 
--- | A baseline validator which does nothing but returning 'True'. We use it as
--- baseline to measure the deviation for cost execution of other validators.
-data EmptyValidator
-
-instance Scripts.ValidatorTypes EmptyValidator where
-  type DatumType EmptyValidator = ()
-  type RedeemerType EmptyValidator = ()
-
-emptyValidator :: Scripts.TypedValidator EmptyValidator
-emptyValidator =
-  Scripts.mkTypedValidator @EmptyValidator
-    $$(Plutus.compile [||\() () _ctx -> True||])
-    $$(Plutus.compile [||wrap||])
- where
-  wrap = Scripts.wrapValidator @() @()
-
 -- | A validator for measuring cost of MT membership validation.
 data MerkleTreeValidator
 

hydra-node/hydra-node.cabal

@@ -190,25 +190,36 @@ executable tx-cost
   import:         project-config
   hs-source-dirs: exe/tx-cost
   main-is:        Main.hs
+  other-modules:  Validators
   build-depends:
     , base
     , bytestring
-    , containers
+    , cardano-api
+    , cardano-binary
+    , cardano-crypto-class
     , cardano-ledger-alonzo
     , cardano-ledger-core
     , cardano-ledger-shelley
     , cardano-ledger-shelley-ma
+    , containers
     , hydra-node
-    , hydra-prelude
     , hydra-plutus
+    , hydra-prelude
     , hydra-test-utils
-    , plutus-tx
+    , plutus-ledger
     , plutus-ledger-api
+    , plutus-merkle-tree
+    , plutus-tx
+    , plutus-tx-plugin
     , QuickCheck
     , strict-containers
 
   ghc-options:    -threaded -rtsopts
 
+  if flag(hydra-development)
+    -- NOTE(SN): should fix HLS choking on PlutusTx plugin
+    ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors
+
 test-suite tests
   import:             project-config
   ghc-options:        -threaded -rtsopts -with-rtsopts=-N