Skip to content

Commit b56b1a6

Browse files
cootcoot
authored
Merge pull request #5191 from IntersectMBO/coot/tx-submission-benchmark
microbenchmarks of makeDecisions
2 parents a01d6eb + d1bc0a7 commit b56b1a6

File tree

11 files changed

+148
-41
lines changed

11 files changed

+148
-41
lines changed

‎ouroboros-network-testing/ouroboros-network-testing.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,7 @@ library
6868
cborg >=0.2.1 && <0.3,
6969
containers,
7070
contra-tracer,
71+
deepseq,
7172
deque ^>=0.4,
7273
io-classes:{io-classes, si-timers, strict-stm} ^>=1.8.0.1,
7374
io-sim,

‎ouroboros-network-testing/src/Test/Ouroboros/Network/Data/Script.hs‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
1-
{-# LANGUAGE DeriveTraversable #-}
2-
{-# LANGUAGE DerivingVia #-}
3-
{-# LANGUAGE TupleSections #-}
1+
{-# LANGUAGE DeriveTraversable #-}
2+
{-# LANGUAGE DerivingVia #-}
3+
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
4+
{-# LANGUAGE TupleSections #-}
45

56
module Test.Ouroboros.Network.Data.Script
67
( -- * Test scripts
@@ -40,6 +41,7 @@ import Data.Set qualified as Set
4041
import Control.Concurrent.Class.MonadSTM (TVar)
4142
import Control.Concurrent.Class.MonadSTM qualified as LazySTM
4243
import Control.Concurrent.Class.MonadSTM.Strict
44+
import Control.DeepSeq
4345
import Control.Monad.Class.MonadAsync
4446
import Control.Monad.Class.MonadFork
4547
import Control.Monad.Class.MonadTimer.SI
@@ -55,6 +57,7 @@ import Test.QuickCheck
5557

5658
newtype Script a = Script (NonEmpty a)
5759
deriving (Eq, Show, Functor, Foldable, Traversable)
60+
deriving newtype NFData
5861

5962
singletonScript :: a -> Script a
6063
singletonScript x = Script (x :| [])

‎ouroboros-network/bench/Main.hs‎

Lines changed: 62 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -2,23 +2,73 @@
22

33
module Main (main) where
44

5+
import Control.DeepSeq
6+
import Control.Exception (evaluate)
7+
import Debug.Trace (traceMarkerIO)
8+
import System.Random.SplitMix qualified as SM
59
import Test.Tasty.Bench
610

11+
import Ouroboros.Network.TxSubmission.Inbound.V2.Decision qualified as Tx
12+
import Test.Ouroboros.Network.TxSubmission.TxLogic qualified as TX
13+
(mkDecisionContext)
14+
715
import Test.Ouroboros.Network.PeerSelection.PeerMetric
816
(microbenchmark1GenerateInput, microbenchmark1ProcessInput)
917

1018
main :: IO ()
11-
main = do
12-
is <- mapM (microbenchmark1GenerateInput False . snd) benchmarks
19+
main =
1320
defaultMain
14-
[bgroup "ouroboros-network:sim-benchmarks"
15-
[ bench (unwords ["microbenchmark1",name])
16-
$ nfAppIO microbenchmark1ProcessInput i
17-
| ((name,_),i) <- zip benchmarks is
18-
]
21+
[ bgroup "ouroboros-network:sim-benchmarks"
22+
[ bgroup "PeerMetrics"
23+
[ env (microbenchmark1GenerateInput False 1_000) $ \i ->
24+
bench "1k" $ nfAppIO microbenchmark1ProcessInput i
25+
, env (microbenchmark1GenerateInput False 10_000) $ \i ->
26+
bench "10k" $ nfAppIO microbenchmark1ProcessInput i
27+
, env (microbenchmark1GenerateInput False 100_000) $ \i ->
28+
bench "100k" $ nfAppIO microbenchmark1ProcessInput i
29+
]
30+
, bgroup "TxLogic"
31+
[ env (do let a = TX.mkDecisionContext (SM.mkSMGen 131) 10
32+
evaluate (rnf a)
33+
traceMarkerIO "evaluated decision context"
34+
return a
35+
)
36+
(\a ->
37+
bench "makeDecisions: 10"
38+
$ nf (uncurry Tx.makeDecisions) a
39+
)
40+
, env (do let a = TX.mkDecisionContext (SM.mkSMGen 131) 100
41+
evaluate (rnf a)
42+
traceMarkerIO "evaluated decision context"
43+
return a
44+
)
45+
(\a ->
46+
bench "makeDecisions: 100"
47+
$ nf (uncurry Tx.makeDecisions) a
48+
)
49+
, env (do let a = TX.mkDecisionContext (SM.mkSMGen 361) 1_000
50+
evaluate (rnf a)
51+
traceMarkerIO "evaluated decision context"
52+
return a
53+
)
54+
(\a ->
55+
bench "makeDecisions: 1000"
56+
$ nf (uncurry Tx.makeDecisions) a
57+
)
58+
{-
59+
, env (do
60+
smGen <- SM.initSMGen
61+
print smGen
62+
let a = TX.mkDecisionContext smGen 1000
63+
evaluate (rnf a)
64+
traceMarkerIO "evaluated decision context"
65+
return a
66+
)
67+
(\a ->
68+
bench "makeDecisions: random"
69+
$ nf (uncurry Tx.makeDecisions) a
70+
)
71+
-}
72+
]
73+
]
1974
]
20-
where
21-
benchmarks = [("1k" , 1000)
22-
,("10k" , 10_000)
23-
,("100k",100_000)
24-
]

‎ouroboros-network/ouroboros-network.cabal‎

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -345,6 +345,7 @@ library testlib
345345
psqueues,
346346
random,
347347
serialise,
348+
splitmix,
348349
tasty,
349350
tasty-hunit,
350351
tasty-quickcheck,
@@ -506,18 +507,21 @@ benchmark sim-benchmarks
506507
main-is: Main.hs
507508
build-depends:
508509
base,
509-
ouroboros-network:testlib,
510+
deepseq,
511+
ouroboros-network:{ouroboros-network, testlib},
512+
splitmix,
510513
tasty-bench >=0.3.5,
511514

515+
-- We use `-fproc-alignemtn` option to avoid skewed results due to changes in cache-line
516+
-- alignment. See https://github.com/Bodigrim/tasty-bench#comparison-against-baseline
517+
-- We use threaded RTS, because of
518+
-- https://gitlab.haskell.org/ghc/ghc/-/issues/25165
512519
ghc-options:
513520
-fno-ignore-asserts
521+
-threaded
522+
-rtsopts
514523
-with-rtsopts=-A32m
524+
-fproc-alignment=64
515525
+RTS
516526
-T
517527
-RTS
518-
519-
-- We use this option to avoid skewed results due to changes in cache-line
520-
-- alignment. See
521-
-- https://github.com/Bodigrim/tasty-bench#comparison-against-baseline
522-
if impl(ghc >=8.6)
523-
ghc-options: -fproc-alignment=64

‎ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -84,7 +84,7 @@ makeDecisions policy st =
8484
orderByRejections :: Hashable peeraddr
8585
=> Int
8686
-> Map peeraddr (PeerTxState txid tx)
87-
-> [ (peeraddr, PeerTxState txid tx)]
87+
-> [(peeraddr, PeerTxState txid tx)]
8888
orderByRejections salt =
8989
List.sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr))
9090
. Map.toList
@@ -103,7 +103,7 @@ data St peeraddr txid tx =
103103
-- ^ acknowledged `txid` with multiplicities. It is used to update
104104
-- `referenceCounts`.
105105

106-
stInSubmissionToMempoolTxs :: Set txid
106+
stInSubmissionToMempoolTxs :: !(Set txid)
107107
-- ^ TXs on their way to the mempool. Used to prevent issueing new
108108
-- fetch requests for them.
109109
}
@@ -258,10 +258,12 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer,
258258
stInflight
259259
-- remove `tx`s which were already downloaded by some
260260
-- other peer or are in-flight or unknown by this peer.
261-
`Map.withoutKeys`
262-
(Map.keysSet bufferedTxs <> requestedTxsInflight <> unknownTxs
263-
<> stInSubmissionToMempoolTxs)
264-
261+
`Map.withoutKeys` (
262+
Map.keysSet bufferedTxs
263+
<> requestedTxsInflight
264+
<> unknownTxs
265+
<> stInSubmissionToMempoolTxs
266+
)
265267
)
266268
requestedTxsInflightSize
267269
-- pick from `txid`'s which are available from that given

‎ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.Policy
88
, NumTxIdsToReq (..)
99
) where
1010

11+
import Control.DeepSeq
1112
import Control.Monad.Class.MonadTime.SI
1213
import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..))
1314
import Ouroboros.Network.SizeInBytes (SizeInBytes (..))
@@ -64,6 +65,9 @@ data TxDecisionPolicy = TxDecisionPolicy {
6465
}
6566
deriving Show
6667

68+
instance NFData TxDecisionPolicy where
69+
rnf TxDecisionPolicy{} = ()
70+
6771
defaultTxDecisionPolicy :: TxDecisionPolicy
6872
defaultTxDecisionPolicy =
6973
TxDecisionPolicy {

‎ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs‎

Lines changed: 10 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -186,14 +186,18 @@ splitAcknowledgedTxIds
186186
(txIdsToRequest, acknowledgedTxIds', unacknowledgedTxIds')
187187
where
188188
(acknowledgedTxIds', unacknowledgedTxIds')
189-
= StrictSeq.spanl (\txid -> (txid `Map.member` bufferedTxs
190-
|| txid `Set.member` unknownTxs
191-
|| txid `Map.member` downloadedTxs)
192-
&& txid `Set.notMember` requestedTxsInflight
189+
= StrictSeq.spanl (\txid ->
190+
txid `Set.notMember` requestedTxsInflight
191+
&& (
192+
txid `Map.member` downloadedTxs
193+
|| txid `Set.member` unknownTxs
194+
|| txid `Map.member` bufferedTxs
195+
)
193196
)
194197
unacknowledgedTxIds
195-
numOfUnacked = StrictSeq.length unacknowledgedTxIds
196-
numOfAcked = StrictSeq.length acknowledgedTxIds'
198+
199+
numOfUnacked = StrictSeq.length unacknowledgedTxIds
200+
numOfAcked = StrictSeq.length acknowledgedTxIds'
197201
unackedAndRequested = fromIntegral numOfUnacked + requestedTxIdsInflight
198202

199203
txIdsToRequest =

‎ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
12
{-# LANGUAGE DeriveGeneric #-}
23
{-# LANGUAGE DerivingStrategies #-}
34
{-# LANGUAGE ExistentialQuantification #-}
@@ -35,6 +36,7 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.Types
3536
, TxSubmissionProtocolError (..)
3637
) where
3738

39+
import Control.DeepSeq
3840
import Control.Exception (Exception (..))
3941
import Control.Monad.Class.MonadTime.SI
4042
import Data.Map.Strict (Map)
@@ -132,7 +134,7 @@ data PeerTxState txid tx = PeerTxState {
132134
toMempoolTxs :: !(Map txid tx)
133135

134136
}
135-
deriving (Eq, Show, Generic)
137+
deriving (Eq, Show, Generic, NFData)
136138

137139
instance ( NoThunks txid
138140
, NoThunks tx
@@ -242,7 +244,7 @@ data SharedTxState peeraddr txid tx = SharedTxState {
242244
-- | Rng used to randomly order peers
243245
peerRng :: !StdGen
244246
}
245-
deriving (Eq, Show, Generic)
247+
deriving (Eq, Show, Generic, NFData)
246248

247249
instance ( NoThunks peeraddr
248250
, NoThunks tx
@@ -256,7 +258,7 @@ instance ( NoThunks peeraddr
256258
--
257259

258260
newtype TxsToMempool txid tx = TxsToMempool { listOfTxsToMempool :: [(txid, tx)] }
259-
deriving newtype (Eq, Show, Semigroup, Monoid)
261+
deriving newtype (Eq, Show, Semigroup, Monoid, NFData)
260262

261263

262264
-- | Decision made by the decision logic. Each peer will receive a 'Decision'.
@@ -290,6 +292,10 @@ data TxDecision txid tx = TxDecision {
290292
}
291293
deriving (Show, Eq)
292294

295+
instance (NFData txid, NFData tx) => NFData (TxDecision txid tx) where
296+
-- all fields except `txdTxsToMempool` when evaluated to WHNF evaluate to NF.
297+
rnf TxDecision {txdTxsToMempool} = rnf txdTxsToMempool
298+
293299
-- | A non-commutative semigroup instance.
294300
--
295301
-- /note:/ this instance must be consistent with `pickTxsToDownload` and how

‎ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs‎

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
11
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
24
{-# LANGUAGE DerivingStrategies #-}
35
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
46
{-# LANGUAGE LambdaCase #-}
@@ -27,6 +29,7 @@ import Data.Map.Merge.Strict qualified as Map
2729
import Data.Map.Strict (Map)
2830
import Data.Map.Strict qualified as Map
2931
import Data.Set qualified as Set
32+
import GHC.Generics
3033

3134
import Network.Mux.Trace (TraceLabelPeer (..))
3235

@@ -73,7 +76,7 @@ instance Arbitrary TestAddress where
7376
data Event =
7477
FetchedHeader TestAddress SlotNo
7578
| FetchedBlock TestAddress SlotNo SizeInBytes
76-
deriving Show
79+
deriving (Show, Generic, NFData)
7780

7881
eventPeer :: Event -> TestAddress
7982
eventPeer (FetchedHeader peer _) = peer
@@ -100,6 +103,7 @@ instance Arbitrary Event where
100103

101104
newtype FixedScript = FixedScript { getFixedScript :: Script Event }
102105
deriving Show
106+
deriving newtype NFData
103107

104108
-- | Order events by 'SlotNo'
105109
--
@@ -443,12 +447,15 @@ microbenchmark1GenerateInput verbose' n = do
443447
es <- generate (vector n)
444448
let fixedScript = mkFixedScript (Script (NonEmpty.fromList es))
445449
when verbose' $
446-
mapM_ print (let FixedScript s = fixedScript in s)
450+
mapM_ print (getFixedScript fixedScript)
447451
return fixedScript
448452

453+
-- TODO:
454+
-- * we shouldn't use QuickCheck
455+
-- * and we shouldn't use IOSim (which `prop_simScript`) is using.
449456
microbenchmark1ProcessInput :: FixedScript -> IO ()
450457
microbenchmark1ProcessInput =
451-
quickCheckWith (stdArgs{maxSuccess=1}) . prop_simScript
458+
quickCheckWith (stdArgs{maxSuccess=1,chatty=False}) . prop_simScript
452459

453460
microbenchmark1 :: Bool -> Int -> IO ()
454461
microbenchmark1 verbose' n =

‎ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,8 @@ module Test.Ouroboros.Network.TxSubmission.TxLogic
1919
, PeerAddr
2020
, sharedTxStateInvariant
2121
, InvariantStrength (..)
22+
-- * Utils
23+
, mkDecisionContext
2224
) where
2325

2426
import Prelude hiding (seq)
@@ -39,6 +41,7 @@ import Data.Set (Set)
3941
import Data.Set qualified as Set
4042
import Data.Typeable
4143
import System.Random (StdGen, mkStdGen)
44+
import System.Random.SplitMix (SMGen)
4245

4346
import NoThunks.Class
4447

@@ -55,6 +58,8 @@ import Test.Ouroboros.Network.TxSubmission.Types
5558

5659
import Test.QuickCheck
5760
import Test.QuickCheck.Function (apply)
61+
import Test.QuickCheck.Gen (Gen (..))
62+
import Test.QuickCheck.Random (QCGen (..))
5863
import Test.Tasty (TestTree, testGroup)
5964
import Test.Tasty.QuickCheck (testProperty)
6065
import Text.Pretty.Simple
@@ -1226,6 +1231,25 @@ instance (Arbitrary txid, Ord txid, Function txid, CoArbitrary txid)
12261231
]
12271232

12281233

1234+
-- | Construct decision context in a deterministic way. For micro benchmarks.
1235+
--
1236+
-- It is based on QuickCheck's `arbitrary` instance for `ArbDecisionContexts.
1237+
--
1238+
mkDecisionContext :: SMGen
1239+
-- ^ pseudo random generator
1240+
-> Int
1241+
-- ^ size
1242+
-> (TxDecisionPolicy, SharedTxState PeerAddr TxId (Tx TxId))
1243+
mkDecisionContext stdgen size =
1244+
case unGen gen (QCGen stdgen) size of
1245+
ArbDecisionContexts { arbDecisionPolicy = policy,
1246+
arbSharedState = sharedState
1247+
} -> (policy, sharedState)
1248+
where
1249+
gen :: Gen (ArbDecisionContexts TxId)
1250+
gen = arbitrary
1251+
1252+
12291253
prop_ArbDecisionContexts_generator
12301254
:: ArbDecisionContexts TxId
12311255
-> Property

0 commit comments

Comments
 (0)