-
Notifications
You must be signed in to change notification settings - Fork 155
/
Balance.hs
103 lines (88 loc) · 3.08 KB
/
Balance.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Bench.Cardano.Ledger.Balance (balanceBenchmarks) where
import Bench.Cardano.Ledger.ApplyTx (ShelleyBench)
import Cardano.Ledger.Coin
import Cardano.Ledger.UTxO (sumAllValue)
import Control.DeepSeq
import Control.Monad
import Criterion
import Data.Foldable as F
import Data.Map.Strict as Map
import System.Random.Stateful
--------------------------------------------------------------------------------
-- Benchmark suite
--------------------------------------------------------------------------------
-- FIXME: This benchmark needs to be rewritten to work on an actual TxOut,
-- rather than a T newtype because `sumAllValue` now works only on TxOut
newtype T = T {value :: Coin}
deriving (NFData)
type Key = Int
balanceBenchmarks :: Benchmark
balanceBenchmarks =
let stdGen = mkStdGen 2021
n = 100000
utxo :: [((Int, Key), T)]
utxo =
runStateGen_ stdGen $ \gen ->
replicateM n $ do
txIn <- (,) <$> uniformRM (0, 15) gen <*> uniformM gen
txOut <- T . Coin <$> uniformRM (0, 1000) gen
pure (txIn, txOut)
in bgroup
"balance"
[ bgroup
"sumAllValue"
[ env (pure (snd <$> utxo)) $
bench "[Coin]" . nf sumAllValueList
, env (pure (Map.fromList utxo)) $
bench "Map TxIn Coin" . nf sumAllValueMap
]
, bgroup
"foldMap"
[ env (pure (snd <$> utxo)) $
bench "[Coin]" . nf foldMapList
, env (pure (Map.fromList utxo)) $
bench "Map TxIn Coin" . nf foldMapMap
]
, bgroup
"foldMap'"
[ env (pure (snd <$> utxo)) $
bench "[Coin]" . nf foldMap'List
, env (pure (Map.fromList utxo)) $
bench "Map TxIn Coin" . nf foldMap'Map
]
, bgroup
"foldl'"
[ env (pure (snd <$> utxo)) $
bench "[Coin]" . nf foldl'List
, env (pure (Map.fromList utxo)) $
bench "Map TxIn Coin" . nf foldl'Map
]
]
sumAllValueList :: [T] -> Coin
sumAllValueList xs = sumAllValue @ShelleyBench xs
{-# NOINLINE sumAllValueList #-}
sumAllValueMap :: Map (Int, Key) T -> Coin
sumAllValueMap xs = sumAllValue @ShelleyBench xs
{-# NOINLINE sumAllValueMap #-}
foldMapList :: [T] -> Coin
foldMapList xs = F.foldMap value xs
{-# NOINLINE foldMapList #-}
foldMapMap :: Map (Int, Key) T -> Coin
foldMapMap xs = F.foldMap value xs
{-# NOINLINE foldMapMap #-}
foldMap'List :: [T] -> Coin
foldMap'List xs = F.foldMap' value xs
{-# NOINLINE foldMap'List #-}
foldMap'Map :: Map (Int, Key) T -> Coin
foldMap'Map xs = F.foldMap' value xs
{-# NOINLINE foldMap'Map #-}
foldl'List :: [T] -> Coin
foldl'List xs = F.foldl' (\acc tx -> acc <> value tx) mempty xs
{-# NOINLINE foldl'List #-}
foldl'Map :: Map (Int, Key) T -> Coin
foldl'Map xs = F.foldl' (\acc tx -> acc <> value tx) mempty xs
{-# NOINLINE foldl'Map #-}