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