From 6ef64f723417b917958c68c81d102781b6a66e2b Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 19 Apr 2021 11:19:22 +0200 Subject: [PATCH 1/2] Benchmarks for 'aggregateUTxOCoinByCredential' It was only after writing this that I noticed we already had some benchmarks for this function, in - https://github.com/input-output-hk/cardano-ledger-specs/blob/master/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs and - https://github.com/input-output-hk/cardano-ledger-specs/blob/master/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/Main.hs#L221 However, upon examining that benchmark, I think it's still worth having this one (and maybe dropping the other). The existing benchmark uses `gen` (I believe without fixing the seed), making it hard to test the same case each time. And whilst we can control the size of the UTxO, this new benchmark allows explicit control over the key things important to the UTxO aggregation calculation, namely: - The number of base stake addresses - The number of pointer stake addresses (which require some additional computation), and - The "delegation" factor; i.e. the number of TxOuts for each stake address. --- .../Bench/Cardano/Ledger/EpochBoundary.hs | 129 ++++++++++++++++++ cardano-ledger-test/bench/Main.hs | 8 +- cardano-ledger-test/cardano-ledger-test.cabal | 2 + 3 files changed, 138 insertions(+), 1 deletion(-) create mode 100644 cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs diff --git a/cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs b/cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs new file mode 100644 index 0000000000..ed3c79aa1e --- /dev/null +++ b/cardano-ledger-test/bench/Bench/Cardano/Ledger/EpochBoundary.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | Benchmarks for things which happen on an epoch boundary. +module Bench.Cardano.Ledger.EpochBoundary where + +import Cardano.Crypto.DSIGN.Mock +import Cardano.Ledger.Coin (Coin (Coin)) +import Cardano.Ledger.Compactible (Compactible (toCompact)) +import Cardano.Ledger.Hashes (EraIndependentTxBody) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.SafeHash + ( SafeToHash (makeHashWithExplicitProxys), + castSafeHash, + ) +import Cardano.Ledger.ShelleyMA () +import qualified Cardano.Ledger.Val as Val +import Criterion +import Data.ByteString (ByteString) +import Data.Functor ((<&>)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import Data.Proxy +import Data.Word (Word64) +import Shelley.Spec.Ledger.Address (Addr (Addr)) +import Shelley.Spec.Ledger.BaseTypes (Network (Testnet)) +import Shelley.Spec.Ledger.CompactAddr (compactAddr) +import Shelley.Spec.Ledger.Credential + ( Credential (KeyHashObj), + PaymentCredential, + Ptr (..), + StakeCredential, + StakeReference (StakeRefBase, StakeRefPtr), + ) +import Shelley.Spec.Ledger.EpochBoundary (aggregateUtxoCoinByCredential) +import Shelley.Spec.Ledger.Keys (VKey (..), hashKey) +import Shelley.Spec.Ledger.Slot (SlotNo (SlotNo)) +import Shelley.Spec.Ledger.TxBody (TxId (..), TxIn (TxInCompact), TxOut (..)) +import Shelley.Spec.Ledger.UTxO (UTxO (UTxO)) +import Test.Cardano.Ledger.EraBuffet (TestCrypto) + +type TestEra = MaryEra TestCrypto + +payCred :: PaymentCredential TestCrypto +payCred = KeyHashObj (hashKey . VKey $ VerKeyMockDSIGN 0) + +-- | Infinite list of transaction inputs +txIns :: [TxIn TestCrypto] +txIns = [0 ..] <&> TxInCompact txId + where + txId = + TxId . castSafeHash $ + makeHashWithExplicitProxys + (Proxy @TestCrypto) + (Proxy @EraIndependentTxBody) + ("Galadriel" :: ByteString) + +-- | Generate TxOuts for each stake credential. +txOutsFromCreds :: [StakeCredential TestCrypto] -> [TxOut TestEra] +txOutsFromCreds creds = + [ TxOutCompact + (compactAddr $ Addr Testnet payCred (StakeRefBase cred)) + (fromJust . toCompact . Val.inject $ Coin 100) + | cred <- creds + ] + +txOutsFromPtrs :: [Ptr] -> [TxOut TestEra] +txOutsFromPtrs ptrs = + [ TxOutCompact + (compactAddr $ Addr Testnet payCred (StakeRefPtr ptr)) + (fromJust . toCompact . Val.inject $ Coin 200) + | ptr <- ptrs + ] + +-- | Generate n stake credentials +stakeCreds :: Word64 -> [StakeCredential TestCrypto] +stakeCreds n = + [0 .. n] + <&> (\i -> KeyHashObj (hashKey . VKey $ VerKeyMockDSIGN i)) + +-- | Generate pointers to a list of stake credentials +stakePtrs :: [StakeCredential c] -> Map Ptr (StakeCredential c) +stakePtrs creds = + Map.fromList + [ (Ptr (SlotNo i) 0 0, cred) + | (i, cred) <- zip [0 ..] creds + ] + +utxo :: Word64 -> Map Ptr c -> Int -> UTxO TestEra +utxo noBase ptrMap dupFactor = + UTxO $ + Map.fromList + [ (txIn, txOut) + | let txOutB = txOutsFromCreds $ stakeCreds noBase, + let txOutP = txOutsFromPtrs $ Map.keys ptrMap, + let allTxs = txOutP ++ txOutB, + txIn <- take (dupFactor * length allTxs) txIns, + txOut <- allTxs + ] + +data AggTestSetup = AggTestSetup + { atsPtrMap :: !(Map Ptr (StakeCredential TestCrypto)), + atsUTxO :: !(UTxO TestEra) + } + +sizedAggTestSetup :: Word64 -> Word64 -> Int -> AggTestSetup +sizedAggTestSetup noBase noPtr dupFactor = AggTestSetup pm ut + where + pm = stakePtrs $ stakeCreds noPtr + ut = utxo noBase pm dupFactor + +aggregateUtxoBench :: Benchmark +aggregateUtxoBench = + bgroup + "aggregateUtxoCoinByCredential" + [ bench "100/100" $ whnf go (sizedAggTestSetup 100 100 1), + bench "10/10 * 100" $ whnf go (sizedAggTestSetup 10 10 100), + bench "100/100 * 10" $ whnf go (sizedAggTestSetup 100 100 10), + bench "1000/1000" $ whnf go (sizedAggTestSetup 1000 1000 1), + bench "1000/1000 * 10" $ whnf go (sizedAggTestSetup 1000 1000 10), + bench "10000/1000" $ whnf go (sizedAggTestSetup 10000 1000 1), + bench "1000/10000" $ whnf go (sizedAggTestSetup 1000 10000 1), + bench "10000/10000" $ whnf go (sizedAggTestSetup 10000 10000 1) + ] + where + go AggTestSetup {atsPtrMap, atsUTxO} = + aggregateUtxoCoinByCredential atsPtrMap atsUTxO Map.empty diff --git a/cardano-ledger-test/bench/Main.hs b/cardano-ledger-test/bench/Main.hs index d134b46552..e730571432 100644 --- a/cardano-ledger-test/bench/Main.hs +++ b/cardano-ledger-test/bench/Main.hs @@ -5,6 +5,7 @@ module Main where import qualified Bench.Cardano.Ledger.ApplyTx as ApplyTx +import qualified Bench.Cardano.Ledger.EpochBoundary as Epoch import qualified Bench.Cardano.Ledger.Serialisation.Generators as SerGen import Criterion.Main ( -- bench, bgroup, nf, @@ -12,4 +13,9 @@ import Criterion.Main ) main :: IO () -main = defaultMain [SerGen.benchTxGeneration, ApplyTx.applyTxBenchmarks] +main = + defaultMain + [ SerGen.benchTxGeneration, + ApplyTx.applyTxBenchmarks, + Epoch.aggregateUtxoBench + ] diff --git a/cardano-ledger-test/cardano-ledger-test.cabal b/cardano-ledger-test/cardano-ledger-test.cabal index afd03eb127..30be05b418 100644 --- a/cardano-ledger-test/cardano-ledger-test.cabal +++ b/cardano-ledger-test/cardano-ledger-test.cabal @@ -46,10 +46,12 @@ benchmark bench main-is: Main.hs other-modules: Bench.Cardano.Ledger.ApplyTx + Bench.Cardano.Ledger.EpochBoundary Bench.Cardano.Ledger.Serialisation.Generators build-depends: bytestring, cardano-binary, + cardano-crypto-class, cardano-ledger-core, cardano-ledger-shelley-ma-test, cardano-ledger-shelley-ma, From b4d31483015b5be0916036edf1a5e578fa14d311 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 19 Apr 2021 11:33:26 +0200 Subject: [PATCH 2/2] Minor performance improvements in UTxO aggregation This makes a couple of minor improvements in the function 'aggregateUtxoCoinByCredential', as measured by the new benchmark introduced. I tried a few variants; see https://drive.google.com/drive/u/1/folders/1o7r4EF0uM5gfhtf3_GoMSJdoHc_d6Xtc for the full reports. This version seems to shave maybe 20% off of the 20K UTxO run. Interestingly, a variant where we try to explicitly deserialise only the stake ref (using `deserialiseAddrStakeRef`) was _considerably_ slower. I'm not immediately sure why! --- .../src/Shelley/Spec/Ledger/EpochBoundary.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs index 18953cce4a..6eb473a02b 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -105,15 +106,17 @@ deriving newtype instance -- | Sum up all the Coin for each staking Credential aggregateUtxoCoinByCredential :: forall era. - (Era era, HasField "address" (Core.TxOut era) (Addr (Crypto era))) => + ( Era era, + HasField "address" (Core.TxOut era) (Addr (Crypto era)) + ) => Map Ptr (Credential 'Staking (Crypto era)) -> UTxO era -> Map (Credential 'Staking (Crypto era)) Coin -> Map (Credential 'Staking (Crypto era)) Coin aggregateUtxoCoinByCredential ptrs (UTxO u) initial = - Map.foldr accum initial u + Map.foldl' accum initial u where - accum out ans = + accum !ans out = case (getField @"address" out, getField @"value" out) of (Addr _ _ (StakeRefPtr p), c) -> case Map.lookup p ptrs of