aggregateUTxOCoinByCredential benchmarks and performance tuning

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

cardano-ledger-test/bench/Main.hs

@@ -5,11 +5,17 @@
 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,
     defaultMain,
   )
 
 main :: IO ()
-main = defaultMain [SerGen.benchTxGeneration, ApplyTx.applyTxBenchmarks]
+main =
+  defaultMain
+    [ SerGen.benchTxGeneration,
+      ApplyTx.applyTxBenchmarks,
+      Epoch.aggregateUtxoBench
+    ]

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,

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