Skip to content

Commit 7fa719c

Browse files
nbacqueynbacquey
committed
WIP: benchmarks for object diffusion logic
1 parent ff925ad commit 7fa719c

File tree

5 files changed

+239
-7
lines changed

5 files changed

+239
-7
lines changed

‎ouroboros-consensus/bench/ObjectDiffusion-bench/Main.hs‎

Lines changed: 97 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,97 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE ImportQualifiedPost #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE NumericUnderscores #-}
6+
{-# LANGUAGE TypeApplications #-}
7+
8+
-- | This module contains benchmarks for Peras Object diffusion decision logic
9+
-- as implemented by the by the function
10+
-- 'Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision.makeDecision'
11+
module Main (main) where
12+
13+
import Control.DeepSeq (NFData (..))
14+
import Control.Exception (evaluate)
15+
import Data.Hashable (Hashable)
16+
import Debug.Trace (traceMarkerIO)
17+
import GHC.Generics (Generic)
18+
import System.Random.SplitMix qualified as SM
19+
import Test.Tasty.Bench
20+
import Test.QuickCheck (Arbitrary (..))
21+
22+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision qualified as OD
23+
24+
-- TODO: We will probably want to use the actual types used in vote/cert diffusion,
25+
-- instead of placeholders.
26+
newtype DummyPeerAddr = DummyPeerAddr Int
27+
deriving (Eq, Ord, Generic, NFData)
28+
29+
instance Arbitrary DummyPeerAddr where
30+
arbitrary = DummyPeerAddr <$> arbitrary
31+
32+
newtype DummyObjectId = DummyObjectId Int
33+
deriving (Eq, Ord, Generic, Hashable, NFData)
34+
35+
instance Arbitrary DummyObjectId where
36+
arbitrary = DummyObjectId <$> arbitrary
37+
38+
data DummyObject = DummyObject
39+
{ doId :: DummyObjectId
40+
, doPayload :: ()
41+
}
42+
deriving (Generic, NFData)
43+
44+
instance Arbitrary DummyObject where
45+
arbitrary = DummyObject <$> arbitrary <*> arbitrary
46+
47+
main :: IO ()
48+
main =
49+
defaultMain
50+
[ bgroup "ouroboros-consensus:ObjectDiffusion"
51+
[ bgroup "VoteDiffusion"
52+
[ env
53+
(do let a = OD.mkDecisionContext (SM.mkSMGen 123) 10
54+
evaluate (rnf a)
55+
traceMarkerIO "evaluated decision context"
56+
return a
57+
)
58+
(\a -> bench "makeDecisions: 10" $
59+
nf makeVoteDiffusionDecision a
60+
)
61+
, env
62+
(do let a = OD.mkDecisionContext (SM.mkSMGen 456) 100
63+
evaluate (rnf a)
64+
traceMarkerIO "evaluated decision context"
65+
return a
66+
)
67+
(\a -> bench "makeDecisions: 100" $
68+
nf makeVoteDiffusionDecision a
69+
)
70+
, env
71+
(do let a = OD.mkDecisionContext (SM.mkSMGen 789) 1_000
72+
evaluate (rnf a)
73+
traceMarkerIO "evaluated decision context"
74+
return a
75+
)
76+
(\a -> bench "makeDecisions: 1_000" $
77+
nf makeVoteDiffusionDecision a
78+
)
79+
]
80+
, bgroup "CertDiffusion" []
81+
]
82+
]
83+
where
84+
-- TODO: We probably want to use the decision policy for vote/cert diffusion
85+
-- instead of an arbitrary one.
86+
makeVoteDiffusionDecision = \OD.DecisionContext
87+
{ OD.dcRng
88+
, OD.dcHasObject
89+
, OD.dcDecisionPolicy
90+
, OD.dcGlobalState
91+
, OD.dcPrevDecisions
92+
} -> OD.makeDecisions @DummyPeerAddr @DummyObjectId @DummyObject
93+
dcRng
94+
dcHasObject
95+
dcDecisionPolicy
96+
dcGlobalState
97+
dcPrevDecisions

‎ouroboros-consensus/ouroboros-consensus.cabal‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -359,6 +359,7 @@ library
359359
ouroboros-network-protocols ^>=0.15,
360360
primitive,
361361
psqueues ^>=0.2.3,
362+
QuickCheck,
362363
quiet ^>=0.2,
363364
random,
364365
rawlock ^>=0.1.1,
@@ -369,6 +370,7 @@ library
369370
small-steps ^>=1.1,
370371
sop-core ^>=0.5,
371372
sop-extras ^>=0.4,
373+
splitmix,
372374
streaming,
373375
strict >=0.1 && <0.6,
374376
strict-checked-vars ^>=0.2,
@@ -867,6 +869,21 @@ benchmark PerasCertDB-bench
867869
tasty-bench,
868870
unstable-consensus-testlib,
869871

872+
benchmark ObjectDiffusion-bench
873+
import: common-bench
874+
type: exitcode-stdio-1.0
875+
hs-source-dirs: bench/ObjectDiffusion-bench
876+
main-is: Main.hs
877+
other-modules:
878+
build-depends:
879+
base,
880+
deepseq,
881+
hashable,
882+
ouroboros-consensus,
883+
QuickCheck,
884+
splitmix,
885+
tasty-bench,
886+
870887
test-suite doctest
871888
import: common-test
872889
main-is: doctest.hs

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Decision.hs‎

Lines changed: 60 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -7,13 +7,16 @@
77

88
module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision
99
( PeerDecision (..)
10-
, mempty
10+
, makeDecisions
1111

1212
-- * Internal API exposed for testing
13-
, makeDecisions
13+
, DecisionContext (..)
14+
, mkDecisionContext
1415
) where
1516

17+
import Control.DeepSeq (NFData (..))
1618
import Data.Foldable qualified as Foldable
19+
import Data.Hashable (Hashable (..))
1720
import Data.Map.Merge.Strict qualified as Map
1821
import Data.Map.Strict (Map)
1922
import Data.Map.Strict qualified as Map
@@ -25,7 +28,61 @@ import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Policy
2528
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.State
2629
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types
2730
import Ouroboros.Network.Protocol.ObjectDiffusion.Type
28-
import System.Random (StdGen)
31+
import Test.QuickCheck (Arbitrary (..))
32+
import Test.QuickCheck.Gen (Gen (..))
33+
import Test.QuickCheck.Random (QCGen (..))
34+
import System.Random.SplitMix (SMGen, nextInt)
35+
import System.Random (StdGen, mkStdGen)
36+
37+
data DecisionContext peerAddr objectId object = DecisionContext
38+
{ dcRng :: StdGen
39+
, dcHasObject :: (objectId -> Bool)
40+
, dcDecisionPolicy :: DecisionPolicy
41+
, dcGlobalState :: DecisionGlobalState peerAddr objectId object
42+
, dcPrevDecisions :: Map peerAddr (PeerDecision objectId object)
43+
}
44+
45+
instance
46+
( NFData peerAddr
47+
, NFData objectId
48+
, NFData object
49+
) =>
50+
NFData (DecisionContext peerAddr objectId object) where
51+
rnf = undefined
52+
53+
-- TODO: do not generate dcDecisionPolicy arbitrarily, it makes little sense.
54+
-- Instead we should provide decision policies fit for the concrete object types
55+
-- we want to make decisions for.
56+
mkDecisionContext ::
57+
forall peerAddr objectId object.
58+
( Arbitrary peerAddr
59+
, Arbitrary objectId
60+
, Arbitrary object
61+
, Ord peerAddr
62+
, Ord objectId
63+
, Hashable objectId
64+
) =>
65+
SMGen ->
66+
Int ->
67+
DecisionContext peerAddr objectId object
68+
mkDecisionContext stdGen size = unGen gen (QCGen stdGen') size
69+
where
70+
(salt, stdGen') = nextInt stdGen
71+
gen :: Gen (DecisionContext peerAddr objectId object)
72+
gen = do
73+
dcRng <- mkStdGen <$> arbitrary
74+
dcDecisionPolicy <- arbitrary
75+
dcGlobalState <- arbitrary
76+
dcPrevDecisions <- arbitrary
77+
let dcHasObject objId =
78+
hashWithSalt salt objId `mod` 2 == 0
79+
pure $ DecisionContext
80+
{ dcRng
81+
, dcHasObject
82+
, dcDecisionPolicy
83+
, dcGlobalState
84+
, dcPrevDecisions
85+
}
2986

3087
strictSeqToSet :: Ord a => StrictSeq a -> Set a
3188
strictSeqToSet = Set.fromList . Foldable.toList

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Policy.hs‎

Lines changed: 12 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,10 +3,12 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Policy
33
, defaultDecisionPolicy
44
) where
55

6-
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types (ObjectMultiplicity)
6+
import Test.QuickCheck (Arbitrary (..))
7+
8+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types (ObjectMultiplicity (..))
79
import Ouroboros.Network.Protocol.ObjectDiffusion.Type
810
( NumObjectIdsReq (..)
9-
, NumObjectsOutstanding
11+
, NumObjectsOutstanding (..)
1012
, NumObjectsReq (..)
1113
)
1214

@@ -25,6 +27,14 @@ data DecisionPolicy = DecisionPolicy
2527
}
2628
deriving Show
2729

30+
instance Arbitrary DecisionPolicy where
31+
arbitrary = DecisionPolicy
32+
<$> (NumObjectIdsReq <$> arbitrary)
33+
<*> (NumObjectsOutstanding <$> arbitrary)
34+
<*> (NumObjectsReq <$>arbitrary)
35+
<*> (NumObjectsReq <$>arbitrary)
36+
<*> (ObjectMultiplicity <$> arbitrary)
37+
2838
defaultDecisionPolicy :: DecisionPolicy
2939
defaultDecisionPolicy =
3040
DecisionPolicy

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/V2/Types.hs‎

Lines changed: 53 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -46,12 +46,12 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types
4646

4747
import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM, StrictTVar, atomically, newTVarIO)
4848
import Control.Concurrent.Class.MonadSTM.TSem (TSem, newTSem)
49-
import Control.DeepSeq (NFData)
49+
import Control.DeepSeq (NFData (..))
5050
import Control.Exception (Exception (..))
5151
import Data.Map.Strict (Map)
5252
import Data.Map.Strict qualified as Map
5353
import Data.Monoid (Sum (..))
54-
import Data.Sequence.Strict (StrictSeq)
54+
import Data.Sequence.Strict (StrictSeq, fromList)
5555
import Data.Set (Set)
5656
import Data.Word (Word64)
5757
import GHC.Generics (Generic)
@@ -60,6 +60,7 @@ import NoThunks.Class (NoThunks (..))
6060
import Ouroboros.Network.ControlMessage (ControlMessage)
6161
import Ouroboros.Network.Protocol.ObjectDiffusion.Type
6262
import Quiet (Quiet (..))
63+
import Test.QuickCheck (Arbitrary (..), elements)
6364

6465
-- | Semaphore to guard access to the ObjectPool
6566
newtype ObjectPoolSem m = ObjectPoolSem (TSem m)
@@ -108,6 +109,20 @@ data DecisionPeerState objectId object = DecisionPeerState
108109
}
109110
deriving (Eq, Show, Generic)
110111

112+
instance
113+
( Arbitrary objectId
114+
, Arbitrary object
115+
, Ord objectId
116+
) =>
117+
Arbitrary (DecisionPeerState objectId object)
118+
where
119+
arbitrary = DecisionPeerState
120+
<$> (NumObjectIdsReq <$> arbitrary)
121+
<*> (fromList <$> arbitrary)
122+
<*> arbitrary
123+
<*> arbitrary
124+
<*> arbitrary
125+
111126
instance
112127
( NoThunks objectId
113128
, NoThunks object
@@ -125,6 +140,16 @@ data DecisionGlobalState peerAddr objectId object = DecisionGlobalState
125140
}
126141
deriving (Eq, Show, Generic)
127142

143+
instance
144+
( Arbitrary peerAddr
145+
, Arbitrary object
146+
, Arbitrary objectId
147+
, Ord peerAddr
148+
, Ord objectId
149+
) =>
150+
Arbitrary (DecisionGlobalState peerAddr objectId object) where
151+
arbitrary = DecisionGlobalState <$> arbitrary
152+
128153
instance
129154
( NoThunks peerAddr
130155
, NoThunks object
@@ -199,12 +224,38 @@ data PeerDecision objectId object = PeerDecision
199224
}
200225
deriving (Show, Eq)
201226

227+
instance
228+
( Arbitrary objectId
229+
, Ord objectId
230+
) =>
231+
Arbitrary (PeerDecision objectId object) where
232+
arbitrary = PeerDecision
233+
<$> (NumObjectIdsAck <$> arbitrary)
234+
<*> (NumObjectIdsReq <$> arbitrary)
235+
<*> arbitrary
236+
<*> arbitrary
237+
<*> arbitrary
238+
239+
instance
240+
( NFData objectId
241+
, NFData object
242+
) =>
243+
NFData (PeerDecision objectId object) where
244+
rnf = undefined
245+
202246
data PeerDecisionStatus
203247
= DecisionUnread
204248
| DecisionBeingActedUpon
205249
| DecisionCompleted
206250
deriving (Show, Eq)
207251

252+
instance Arbitrary PeerDecisionStatus where
253+
arbitrary = elements
254+
[ DecisionUnread
255+
, DecisionBeingActedUpon
256+
, DecisionCompleted
257+
]
258+
208259
-- | A placeholder when no decision has been made, at the beginning of a loop.
209260
-- Nothing should be read from it except its status.
210261
unavailableDecision :: HasCallStack => PeerDecision objectId object

0 commit comments

Comments
 (0)