Skip to content

Commit f04318b

Browse files
lehinslehins
authored
Merge pull request #5814 from IntersectMBO/lehins/tick-benchmarks
Add TICK and NEWEPOCH benchmarks
2 parents 29c9e7e + 5650247 commit f04318b

2 files changed

Lines changed: 114 additions & 72 deletions

File tree

‎libs/ledger-state/README.md‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -113,3 +113,5 @@ $ cabal bench ledger-state:performance --benchmark-option=--csv=ledger-state:per
113113
The csv file will be saved in the `libs/ledger-state` directory.
114114

115115
Since the `performance` benchmark uses only `new-epoch-state.bin` you don't need to run the `sqlite.db` steps above if you want to run only the `performance` benchmark.
116+
117+
Not all benchmarks require `UTxO` to be loaded, therefore `BENCH_UTXO_PATH` does not need to be set for such benchmarks.

‎libs/ledger-state/bench/Performance.hs‎

Lines changed: 112 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -15,20 +15,22 @@ import Cardano.Ledger.Conway
1515
import qualified Cardano.Ledger.Conway.Rules as Conway
1616
import Cardano.Ledger.Core
1717
import Cardano.Ledger.Shelley.API.Mempool
18+
import Cardano.Ledger.Shelley.API.Validation
1819
import Cardano.Ledger.Shelley.API.Wallet (getFilteredUTxO, getUTxO)
1920
import Cardano.Ledger.Shelley.Genesis (
2021
ShelleyGenesis (..),
2122
fromNominalDiffTimeMicro,
2223
mkShelleyGlobals,
2324
)
2425
import Cardano.Ledger.Shelley.LedgerState
26+
import Cardano.Ledger.Slot
2527
import Cardano.Ledger.State
2628
import Cardano.Ledger.State.UTxO (CurrentEra, readHexUTxO, readNewEpochState)
2729
import Cardano.Ledger.Val
2830
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
2931
import Cardano.Slotting.Time (mkSlotLength)
3032
import Control.DeepSeq
31-
import Control.Monad (when)
33+
import Control.Monad (forM)
3234
import Criterion.Main
3335
import Data.Aeson
3436
import Data.Bifunctor (bimap, first)
@@ -44,8 +46,7 @@ import qualified Data.Set as Set
4446
import Data.Typeable (Typeable)
4547
import GHC.Stack (HasCallStack)
4648
import Lens.Micro ((&), (.~), (^.))
47-
import System.Environment (getEnv)
48-
import System.Exit (die)
49+
import System.Environment (getEnv, lookupEnv)
4950
import System.Random.Stateful
5051

5152
main :: IO ()
@@ -54,19 +55,24 @@ main = do
5455
utxoVarName = "BENCH_UTXO_PATH"
5556
ledgerStateVarName = "BENCH_LEDGER_STATE_PATH"
5657
genesisFilePath <- getEnv genesisVarName
57-
utxoFilePath <- getEnv utxoVarName
58+
mUtxoFilePath <- lookupEnv utxoVarName
5859
ledgerStateFilePath <- getEnv ledgerStateVarName
5960

60-
genesis <- either error id <$> eitherDecodeFileStrict' genesisFilePath
61-
putStrLn $ "Importing UTxO from: " ++ show utxoFilePath
62-
utxo <- readHexUTxO utxoFilePath
63-
putStrLn "Done importing UTxO"
6461
putStrLn $ "Importing NewEpochState from: " ++ show ledgerStateFilePath
65-
es' <- readNewEpochState ledgerStateFilePath
62+
nesFromFile <- readNewEpochState ledgerStateFilePath
6663
putStrLn "Done importing NewEpochState"
6764

68-
let nesUTxOL = nesEsL . esLStateL . lsUTxOStateL . utxoL
69-
es = es' & nesUTxOL .~ utxo
65+
mUtxo <- forM mUtxoFilePath $ \utxoFilePath -> do
66+
putStrLn $ "Importing UTxO from: " ++ show utxoFilePath
67+
utxo <- readHexUTxO utxoFilePath
68+
utxo <$ putStrLn "Done importing UTxO"
69+
70+
genesis <- either error id <$> eitherDecodeFileStrict' genesisFilePath
71+
72+
let newEpochState = case mUtxo of
73+
Nothing -> nesFromFile
74+
Just utxoFromFile -> nesFromFile & utxoL .~ utxoFromFile
75+
utxo = newEpochState ^. utxoL
7076
utxoMap = unUTxO utxo
7177
utxoSize = Map.size utxoMap
7278
largeKeysNum = 100000
@@ -86,72 +92,106 @@ main = do
8692
reapplyTx' mempoolEnv mempoolState =
8793
either (error . show) id
8894
. reapplyTx globals mempoolEnv mempoolState
95+
slotsPerTick =
96+
let f = positiveUnitIntervalNonZeroRational (activeSlotVal (activeSlotCoeff globals))
97+
in round (1 /. f)
8998

90-
when (utxoSize < largeKeysNum) $
91-
die $
92-
"UTxO size is too small (" <> show utxoSize <> " < " <> show largeKeysNum <> ")"
93-
largeKeys <- selectRandomMapKeys 100000 stdGen utxoMap
99+
epochInfo = epochInfoPure globals
100+
-- Assume we are at the very first slot number in the epoch and tick all the way to the very
101+
-- last slot number. Note, that if the assumption was wrong, the whole reward computation and
102+
-- other pulsers might restart, which shouldn't impact the final result at the end of the
103+
-- epoch.
104+
tickToEpochEnd nes =
105+
let !lastSlotNo = epochInfoFirst epochInfo (succ (nesEL nes)) *- Duration slotsPerTick
106+
go !curSlotNo !curNes
107+
| nextSlotNo < lastSlotNo =
108+
go nextSlotNo (applyTickNoEvents @CurrentEra globals curNes nextSlotNo)
109+
| otherwise = curNes
110+
where
111+
!nextSlotNo = curSlotNo +* Duration slotsPerTick
112+
in go (epochInfoFirst epochInfo (nesEL nes)) nes
113+
-- Assume we are at most `slotsPerTick` number of slots away from the first slot number of the
114+
-- next epoch and perform one TICK over that many slot numbers, which has the net result of
115+
-- crossing over the next epoch boundary.
116+
tickOverTheEpochBoundary nes =
117+
let !firstSlotNoOfTheNextEpoch = epochInfoFirst epochInfo (succ (nesEL nes))
118+
in applyTickNoEvents @CurrentEra globals nes firstSlotNoOfTheNextEpoch
94119

95-
defaultMain
96-
[ env (pure (mkMempoolEnv es slotNo, toMempoolState es)) $ \ ~(mempoolEnv, mempoolState) ->
97-
bgroup
98-
"reapplyTx"
99-
[ env (pure validatedTx1) $
100-
bench "Tx1" . whnf (reapplyTx' mempoolEnv mempoolState)
101-
, env (pure validatedTx2) $
102-
bench "Tx2" . whnf (reapplyTx' mempoolEnv mempoolState)
103-
, env (pure validatedTx3) $
104-
bench "Tx3" . whnf (reapplyTx' mempoolEnv mempoolState)
105-
, env
106-
(pure [validatedTx1, validatedTx2, validatedTx3])
107-
$ bench "Tx1+Tx2+Tx3" . whnf (F.foldl' (reapplyTx' mempoolEnv) mempoolState)
108-
]
109-
, env (pure (mkMempoolEnv es slotNo, toMempoolState es)) $ \ ~(mempoolEnv, mempoolState) ->
110-
bgroup
111-
"applyTx"
112-
[ env (pure (extractTx validatedTx1)) $
113-
bench "Tx1" . whnf (applyTx' mempoolEnv mempoolState)
114-
, env (pure (extractTx validatedTx2)) $
115-
bench "Tx2" . whnf (applyTx' mempoolEnv mempoolState)
116-
, env (pure (extractTx validatedTx3)) $
117-
bench "Tx3" . whnf (applyTx' mempoolEnv mempoolState)
118-
, env
119-
(pure [validatedTx1, validatedTx2, validatedTx3])
120-
$ bench "Tx1+Tx2+Tx3"
121-
-- TODO: revert this to `foldl'` without `fmap` after tx's are fixed
122-
. whnf (F.foldlM (\ms -> fmap fst . applyTx' mempoolEnv ms . extractTx) mempoolState)
123-
]
124-
, env (pure utxo) $ \utxo' ->
120+
defaultMain $
121+
[ env (pure $ tickOverTheEpochBoundary $ tickToEpochEnd newEpochState) $ \newEpochStateStart ->
125122
bgroup
126-
"UTxO"
127-
[ bench "sumUTxO" $ nf sumUTxO utxo'
128-
, bench "sumCoinUTxO" $ nf sumCoinUTxO utxo'
129-
, -- We need to filter out all multi-assets to prevent `areAllAdaOnly`
130-
-- from short circuiting and producing results that are way better
131-
-- than the worst case
132-
env (pure $ Map.filter (\txOut -> isAdaOnly (txOut ^. valueTxOutL)) $ unUTxO utxo') $
133-
bench "areAllAdaOnly" . nf areAllAdaOnly
123+
"applyTick"
124+
[ bench "tickToEpochEnd" $ nf tickToEpochEnd newEpochStateStart
125+
, env (pure $ tickToEpochEnd newEpochStateStart) $
126+
bench "tickOverTheEpochBoundary" . nf tickOverTheEpochBoundary
134127
]
135-
, env (pure es) $ \newEpochState ->
136-
let (_, minTxOut) = Map.findMin utxoMap
137-
(_, maxTxOut) = Map.findMax utxoMap
138-
setAddr =
139-
Set.fromList [minTxOut ^. addrTxOutL, maxTxOut ^. addrTxOutL]
140-
in bgroup
141-
"MinMaxTxId"
142-
[ env (pure setAddr) $
143-
bench "getFilteredNewUTxO" . nf (getFilteredUTxO newEpochState)
144-
, env (pure setAddr) $
145-
bench "getFilteredOldUTxO" . nf (getFilteredOldUTxO newEpochState)
146-
]
147-
, bgroup
148-
"DeleteTxOuts"
149-
[ extractKeysBench utxoMap largeKeysNum largeKeys
150-
, extractKeysBench utxoMap 9 (Set.take 9 largeKeys)
151-
, extractKeysBench utxoMap 5 (Set.take 5 largeKeys)
152-
, extractKeysBench utxoMap 2 (Set.take 2 largeKeys)
153-
]
154128
]
129+
++ [ utxoBenchmark
130+
| utxoBenchmark <-
131+
[ env (pure (mkMempoolEnv newEpochState slotNo, toMempoolState newEpochState)) $
132+
\ ~(mempoolEnv, mempoolState) ->
133+
bgroup
134+
"reapplyTx"
135+
[ env (pure validatedTx1) $
136+
bench "Tx1" . whnf (reapplyTx' mempoolEnv mempoolState)
137+
, env (pure validatedTx2) $
138+
bench "Tx2" . whnf (reapplyTx' mempoolEnv mempoolState)
139+
, env (pure validatedTx3) $
140+
bench "Tx3" . whnf (reapplyTx' mempoolEnv mempoolState)
141+
, env
142+
(pure [validatedTx1, validatedTx2, validatedTx3])
143+
$ bench "Tx1+Tx2+Tx3" . whnf (F.foldl' (reapplyTx' mempoolEnv) mempoolState)
144+
]
145+
, env (pure (mkMempoolEnv newEpochState slotNo, toMempoolState newEpochState)) $
146+
\ ~(mempoolEnv, mempoolState) ->
147+
bgroup
148+
"applyTx"
149+
[ env (pure (extractTx validatedTx1)) $
150+
bench "Tx1" . whnf (applyTx' mempoolEnv mempoolState)
151+
, env (pure (extractTx validatedTx2)) $
152+
bench "Tx2" . whnf (applyTx' mempoolEnv mempoolState)
153+
, env (pure (extractTx validatedTx3)) $
154+
bench "Tx3" . whnf (applyTx' mempoolEnv mempoolState)
155+
, env
156+
(pure [validatedTx1, validatedTx2, validatedTx3])
157+
$ bench "Tx1+Tx2+Tx3"
158+
-- TODO: revert this to `foldl'` without `fmap` after tx's are fixed
159+
. whnf (F.foldlM (\ms -> fmap fst . applyTx' mempoolEnv ms . extractTx) mempoolState)
160+
]
161+
, env (pure utxo) $ \utxo' ->
162+
bgroup
163+
"UTxO"
164+
[ bench "sumUTxO" $ nf sumUTxO utxo'
165+
, bench "sumCoinUTxO" $ nf sumCoinUTxO utxo'
166+
, -- We need to filter out all multi-assets to prevent `areAllAdaOnly`
167+
-- from short circuiting and producing results that are way better
168+
-- than the worst case
169+
env (pure $ Map.filter (\txOut -> isAdaOnly (txOut ^. valueTxOutL)) $ unUTxO utxo') $
170+
bench "areAllAdaOnly" . nf areAllAdaOnly
171+
]
172+
, env (pure newEpochState) $ \nes ->
173+
let (_, minTxOut) = Map.findMin utxoMap
174+
(_, maxTxOut) = Map.findMax utxoMap
175+
setAddr =
176+
Set.fromList [minTxOut ^. addrTxOutL, maxTxOut ^. addrTxOutL]
177+
in bgroup
178+
"MinMaxTxId"
179+
[ env (pure setAddr) $ bench "getFilteredNewUTxO" . nf (getFilteredUTxO nes)
180+
, env (pure setAddr) $ bench "getFilteredOldUTxO" . nf (getFilteredOldUTxO nes)
181+
]
182+
]
183+
, utxoSize > 0
184+
]
185+
++ [ env (selectRandomMapKeys largeKeysNum stdGen utxoMap) $ \largeKeys ->
186+
bgroup
187+
"DeleteTxOuts"
188+
[ extractKeysBench utxoMap largeKeysNum largeKeys
189+
, extractKeysBench utxoMap 9 (Set.take 9 largeKeys)
190+
, extractKeysBench utxoMap 5 (Set.take 5 largeKeys)
191+
, extractKeysBench utxoMap 2 (Set.take 2 largeKeys)
192+
]
193+
| utxoSize >= largeKeysNum
194+
]
155195

156196
extractKeysBench ::
157197
(NFData k, NFData a, Ord k) =>

0 commit comments

Comments
 (0)