Skip to content

Commit 56c9c48

Browse files
tbagrel1tbagrel1
committed
Continue working on benchmark gen for ObjectDiffusionV2/makeDecisions
1 parent 7fa719c commit 56c9c48

File tree

6 files changed

+343
-232
lines changed

6 files changed

+343
-232
lines changed

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

Lines changed: 45 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,6 @@
11
{-# LANGUAGE DeriveAnyClass #-}
22
{-# LANGUAGE DeriveGeneric #-}
33
{-# LANGUAGE ImportQualifiedPost #-}
4-
{-# LANGUAGE NamedFieldPuns #-}
54
{-# LANGUAGE NumericUnderscores #-}
65
{-# LANGUAGE TypeApplications #-}
76

@@ -15,11 +14,10 @@ import Control.Exception (evaluate)
1514
import Data.Hashable (Hashable)
1615
import Debug.Trace (traceMarkerIO)
1716
import GHC.Generics (Generic)
17+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision qualified as OD
1818
import System.Random.SplitMix qualified as SM
19-
import Test.Tasty.Bench
2019
import Test.QuickCheck (Arbitrary (..))
21-
22-
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision qualified as OD
20+
import Test.Tasty.Bench
2321

2422
-- TODO: We will probably want to use the actual types used in vote/cert diffusion,
2523
-- instead of placeholders.
@@ -47,51 +45,48 @@ instance Arbitrary DummyObject where
4745
main :: IO ()
4846
main =
4947
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-
)
48+
[ bgroup
49+
"ouroboros-consensus:ObjectDiffusion"
50+
[ bgroup
51+
"VoteDiffusion"
52+
[ env
53+
( do
54+
let a = OD.mkDecisionContext (SM.mkSMGen 123) 10 50 doId Nothing
55+
evaluate (rnf a)
56+
traceMarkerIO "evaluated decision context"
57+
return a
58+
)
59+
( \a ->
60+
bench "makeDecisions: 10" $
61+
nf makeVoteDiffusionDecision a
62+
)
63+
, env
64+
( do
65+
let a = OD.mkDecisionContext (SM.mkSMGen 456) 100 500 doId Nothing
66+
evaluate (rnf a)
67+
traceMarkerIO "evaluated decision context"
68+
return a
69+
)
70+
( \a ->
71+
bench "makeDecisions: 100" $
72+
nf makeVoteDiffusionDecision a
73+
)
74+
, env
75+
( do
76+
let a = OD.mkDecisionContext (SM.mkSMGen 789) 1_000 5_000 doId Nothing
77+
evaluate (rnf a)
78+
traceMarkerIO "evaluated decision context"
79+
return a
80+
)
81+
( \a ->
82+
bench "makeDecisions: 1_000" $
83+
nf makeVoteDiffusionDecision a
84+
)
85+
]
86+
, bgroup "CertDiffusion" []
7987
]
80-
, bgroup "CertDiffusion" []
81-
]
8288
]
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
89+
where
90+
-- TODO: We probably want to use the decision policy for vote/cert diffusion
91+
-- instead of an arbitrary one.
92+
makeVoteDiffusionDecision = \decisionContext -> OD.makeDecisions @DummyPeerAddr @DummyObjectId @DummyObject decisionContext

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

Lines changed: 107 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,7 @@
1+
{-# LANGUAGE BangPatterns #-}
12
{-# LANGUAGE BlockArguments #-}
3+
{-# LANGUAGE DeriveAnyClass #-}
4+
{-# LANGUAGE DeriveGeneric #-}
25
{-# LANGUAGE DerivingVia #-}
36
{-# LANGUAGE ImportQualifiedPost #-}
47
{-# LANGUAGE NamedFieldPuns #-}
@@ -14,25 +17,29 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Decision
1417
, mkDecisionContext
1518
) where
1619

20+
import Cardano.Prelude (for)
1721
import Control.DeepSeq (NFData (..))
22+
import Data.Either (partitionEithers)
1823
import Data.Foldable qualified as Foldable
19-
import Data.Hashable (Hashable (..))
2024
import Data.Map.Merge.Strict qualified as Map
2125
import Data.Map.Strict (Map)
2226
import Data.Map.Strict qualified as Map
27+
import Data.Maybe (fromMaybe)
2328
import Data.Sequence.Strict (StrictSeq)
2429
import Data.Sequence.Strict qualified as StrictSeq
2530
import Data.Set (Set)
2631
import Data.Set qualified as Set
32+
import GHC.Generics (Generic)
2733
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Policy
2834
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.State
2935
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types
3036
import Ouroboros.Network.Protocol.ObjectDiffusion.Type
37+
import System.Random (StdGen, mkStdGen)
38+
import System.Random.SplitMix (SMGen)
3139
import Test.QuickCheck (Arbitrary (..))
32-
import Test.QuickCheck.Gen (Gen (..))
40+
import Test.QuickCheck.Arbitrary (vector)
41+
import Test.QuickCheck.Gen (Gen (..), choose, shuffle)
3342
import Test.QuickCheck.Random (QCGen (..))
34-
import System.Random.SplitMix (SMGen, nextInt)
35-
import System.Random (StdGen, mkStdGen)
3643

3744
data DecisionContext peerAddr objectId object = DecisionContext
3845
{ dcRng :: StdGen
@@ -41,49 +48,108 @@ data DecisionContext peerAddr objectId object = DecisionContext
4148
, dcGlobalState :: DecisionGlobalState peerAddr objectId object
4249
, dcPrevDecisions :: Map peerAddr (PeerDecision objectId object)
4350
}
51+
deriving stock Generic
52+
deriving anyclass NFData
53+
54+
-- TODO: Using `sized` to control size, we could maybe provide directly an instance of Arbitrary for DecisionContext?
55+
56+
partitionWithProb :: Double -> [a] -> Gen ([a], [a])
57+
partitionWithProb p xs = do
58+
partitionEithers
59+
<$> traverse
60+
( \x -> do
61+
r <- choose (0.0, 1.0)
62+
if r < p then return (Left x) else return (Right x)
63+
)
64+
xs
4465

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.
66+
-- TODO: we do not take into account dpMaxNumObjectsInflightTotal here
5667
mkDecisionContext ::
5768
forall peerAddr objectId object.
5869
( Arbitrary peerAddr
59-
, Arbitrary objectId
6070
, Arbitrary object
6171
, Ord peerAddr
6272
, Ord objectId
63-
, Hashable objectId
6473
) =>
6574
SMGen ->
6675
Int ->
76+
Int ->
77+
(object -> objectId) ->
78+
-- | If we want to provide a specific decision policy instead of relying on an arbitrary variation of the default one
79+
Maybe DecisionPolicy ->
6780
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
81+
mkDecisionContext stdGen peersNb objectsNb getId mPolicy = unGen gen (QCGen stdGen) peersNb -- We use peerNb as the size parameter
82+
where
83+
alreadyInPoolRatio :: Double = 0.2
84+
-- How many peers should offer an object compared to the target redundancy
85+
-- for objects (e.g. with targetRedundancy at 2, and this factor at 1.5, then 3 peers will on average offer each object)
86+
advertiseRedundancyOverTargetRedundancy :: Double = 1.5
87+
88+
gen :: Gen (DecisionContext peerAddr objectId object)
89+
gen = do
90+
dcRng <- mkStdGen <$> arbitrary
91+
dcDecisionPolicy@DecisionPolicy{dpTargetObjectRedundancy} <- fromMaybe arbitrary (pure <$> mPolicy)
92+
objects <- vector objectsNb
93+
94+
(alreadyInPool, _) <- partitionWithProb alreadyInPoolRatio objects
95+
let !alreadyInPoolIds = Set.fromList $ getId <$> alreadyInPool
96+
dcHasObject = (`Set.member` alreadyInPoolIds)
97+
98+
dcGlobalState <-
99+
DecisionGlobalState . Map.fromList <$> for [1 .. peersNb] \_ -> do
100+
(peerObjects, _) <-
101+
partitionWithProb
102+
( advertiseRedundancyOverTargetRedundancy
103+
* fromIntegral dpTargetObjectRedundancy
104+
/ fromIntegral peersNb
105+
)
106+
objects
107+
(,) <$> arbitrary <*> (mkPeerState getId dcDecisionPolicy peerObjects)
108+
109+
let dcPrevDecisions = Map.map (\_ -> unavailableDecision) (dgsPeerStates dcGlobalState)
110+
111+
pure $
112+
DecisionContext
80113
{ dcRng
81114
, dcHasObject
82115
, dcDecisionPolicy
83116
, dcGlobalState
84117
, dcPrevDecisions
85118
}
86119

120+
mkPeerState ::
121+
Ord objectId =>
122+
(object -> objectId) -> DecisionPolicy -> [object] -> Gen (DecisionPeerState objectId object)
123+
mkPeerState getId DecisionPolicy{dpMaxNumObjectsOutstanding, dpMaxNumObjectsInflightPerPeer} rawPeerObjects = do
124+
let peerObjects = take (fromIntegral dpMaxNumObjectsOutstanding) rawPeerObjects
125+
126+
let inflightRatio :: Double = 0.1
127+
let owtPoolRatio :: Double = 0.1
128+
-- let availableRatio :: Double = 1 - (inflightRatio + owtPoolRatio)
129+
let owtPoolStillInFifoRatio :: Double = 0.3
130+
let idsInflightSaturation :: Double = 0.8
131+
132+
(objectsAvailable, rest) <- partitionWithProb (1 - (inflightRatio + owtPoolRatio)) peerObjects
133+
(rawObjectsInflight, objectsOwtPool) <-
134+
partitionWithProb (owtPoolRatio / (owtPoolRatio + inflightRatio)) rest
135+
let objectsInflight = take (fromIntegral dpMaxNumObjectsInflightPerPeer) rawObjectsInflight
136+
137+
(owtPoolStillInFifo, _) <- partitionWithProb owtPoolStillInFifoRatio objectsOwtPool
138+
objectsInFifo <- shuffle $ objectsAvailable ++ objectsInflight ++ owtPoolStillInFifo
139+
140+
let maxNumIdsInFlight = max 0 (fromIntegral dpMaxNumObjectsOutstanding - length objectsInFifo)
141+
numIdsInFlight <-
142+
(chooseGeometricWithMedian (round $ idsInflightSaturation * fromIntegral maxNumIdsInFlight))
143+
144+
pure $
145+
DecisionPeerState
146+
{ dpsObjectsAvailableIds = Set.fromList $ getId <$> objectsAvailable
147+
, dpsObjectsInflightIds = Set.fromList $ getId <$> objectsInflight
148+
, dpsObjectsOwtPool = Map.fromList $ (\obj -> (getId obj, obj)) <$> objectsOwtPool
149+
, dpsOutstandingFifo = StrictSeq.fromList $ getId <$> objectsInFifo
150+
, dpsNumIdsInflight = fromIntegral $ numIdsInFlight `max` 0 `min` maxNumIdsInFlight
151+
}
152+
87153
strictSeqToSet :: Ord a => StrictSeq a -> Set a
88154
strictSeqToSet = Set.fromList . Foldable.toList
89155

@@ -93,25 +159,25 @@ makeDecisions ::
93159
( Ord peerAddr
94160
, Ord objectId
95161
) =>
96-
StdGen ->
97-
(objectId -> Bool) ->
98-
-- | decision decisionPolicy
99-
DecisionPolicy ->
100-
-- | decision context
101-
DecisionGlobalState peerAddr objectId object ->
102-
-- | Previous decisions
103-
Map peerAddr (PeerDecision objectId object) ->
162+
DecisionContext peerAddr objectId object ->
104163
-- | New decisions
105164
Map peerAddr (PeerDecision objectId object)
106-
makeDecisions rng hasObject decisionPolicy globalState prevDecisions =
165+
makeDecisions DecisionContext{dcRng, dcHasObject, dcDecisionPolicy, dcGlobalState, dcPrevDecisions} =
107166
let
108167
-- A subset of peers are currently executing a decision. We shouldn't update the decision for them
109-
frozenPeersToDecisions = Map.filter (\PeerDecision{pdStatus} -> pdStatus == DecisionBeingActedUpon) prevDecisions
168+
frozenPeersToDecisions = Map.filter (\PeerDecision{pdStatus} -> pdStatus == DecisionBeingActedUpon) dcPrevDecisions
110169

111170
-- We do it in two steps, because computing the acknowledgment tell which objects from dpsObjectsAvailableIds sets of each peer won't actually be available anymore (as soon as we ack them),
112171
-- so that the pickObjectsToReq function can take this into account.
113-
(ackAndRequestIdsDecisions, peerToIdsToAck) = computeAck hasObject decisionPolicy globalState frozenPeersToDecisions
114-
peersToObjectsToReq = pickObjectsToReq rng hasObject decisionPolicy globalState frozenPeersToDecisions peerToIdsToAck
172+
(ackAndRequestIdsDecisions, peerToIdsToAck) = computeAck dcHasObject dcDecisionPolicy dcGlobalState frozenPeersToDecisions
173+
peersToObjectsToReq =
174+
pickObjectsToReq
175+
dcRng
176+
dcHasObject
177+
dcDecisionPolicy
178+
dcGlobalState
179+
frozenPeersToDecisions
180+
peerToIdsToAck
115181
in
116182
Map.intersectionWith
117183
(\decision objectsToReqIds -> decision{pdObjectsToReqIds = objectsToReqIds})

0 commit comments

Comments
 (0)