Skip to content

Commit debfdfa

Browse files
SaizanSaizan
committed
simulation: integrate certificate creation delay
1 parent 43e70ff commit debfdfa

File tree

4 files changed

+52
-39
lines changed

4 files changed

+52
-39
lines changed

‎simulation/src/LeiosProtocol/Short/Generate.hs

+32-23
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE OverloadedRecordDot #-}
55
{-# LANGUAGE RecordWildCards #-}
66
{-# LANGUAGE ScopedTypeVariables #-}
7+
{-# LANGUAGE TupleSections #-}
78
{-# LANGUAGE TypeApplications #-}
89
{-# LANGUAGE NoFieldSelectors #-}
910

@@ -16,10 +17,12 @@ import Control.Concurrent.Class.MonadSTM (
1617
)
1718
import Control.Exception (assert)
1819
import Control.Monad (forM)
20+
import Data.Bifunctor
1921
import Data.Kind
22+
import Data.Maybe (fromMaybe)
2023
import LeiosProtocol.Common
2124
import LeiosProtocol.Short hiding (Stage (..))
22-
import PraosProtocol.Common (fixupBlock, mkPartialBlock)
25+
import PraosProtocol.Common (CPUTask (CPUTask), fixupBlock, mkPartialBlock)
2326
import System.Random
2427

2528
data BuffersView m = BuffersView
@@ -83,7 +86,7 @@ data BlockGeneratorConfig m = BlockGeneratorConfig
8386
, nodeId :: NodeId
8487
, buffers :: BuffersView m
8588
, schedule :: SlotNo -> m [(SomeRole, Word64)]
86-
, submit :: [SomeAction] -> m ()
89+
, submit :: [([CPUTask], SomeAction)] -> m ()
8790
}
8891

8992
blockGenerator ::
@@ -99,30 +102,36 @@ blockGenerator BlockGeneratorConfig{..} = go (0, 0)
99102
(actions, blkId') <- runStateT (mapM (execute slot) roles) blkId
100103
submit actions
101104
go (blkId', slot + 1)
102-
execute slot (SomeRole r, wins) = assert (wins >= 1) $ SomeAction r <$> execute' slot r wins
103-
execute' :: SlotNo -> Role a -> Word64 -> StateT Int m a
105+
execute slot (SomeRole r, wins) = assert (wins >= 1) $ second (SomeAction r) <$> execute' slot r wins
106+
execute' :: SlotNo -> Role a -> Word64 -> StateT Int m ([CPUTask], a)
104107
execute' slot Base _wins = do
105108
rbData <- lift $ atomically $ buffers.newRBData
106-
let body = mkRankingBlockBody leios nodeId rbData.freshestCertifiedEB rbData.txsPayload
109+
let meb = rbData.freshestCertifiedEB
110+
let !task = CPUTask $ fromMaybe 0 $ leios.delays.certificateCreation . snd <$> meb
111+
let body = mkRankingBlockBody leios nodeId meb rbData.txsPayload
112+
let !rb = fixupBlock @_ @RankingBlock rbData.headAnchor (mkPartialBlock slot body)
107113
-- TODO: maybe submit should do the fixupBlock.
108-
return $! fixupBlock @_ @RankingBlock rbData.headAnchor (mkPartialBlock slot body)
109-
execute' slot Propose wins = do
110-
ibData <- lift $ atomically $ buffers.newIBData
111-
forM [toEnum $ fromIntegral sub | sub <- [0 .. wins - 1]] $ \sub -> do
112-
i <- nextBlkId InputBlockId
113-
let header = mkInputBlockHeader leios i slot sub nodeId ibData.referenceRankingBlock
114-
return $! mkInputBlock leios header ibData.txsPayload
115-
execute' slot Endorse _wins = do
116-
i <- nextBlkId EndorseBlockId
117-
ibs <- lift $ atomically $ buffers.ibs
118-
return $! mkEndorseBlock leios i slot nodeId $ inputBlocksToEndorse leios slot ibs
119-
execute' slot Vote votes = do
120-
votingFor <- lift $ atomically $ do
121-
ibs <- buffers.ibs
122-
ebs <- buffers.ebs
123-
pure $ endorseBlocksToVoteFor leios slot ibs ebs
124-
i <- nextBlkId VoteId
125-
return $! mkVoteMsg leios i slot nodeId votes votingFor
114+
return ([task], rb)
115+
execute' slot Propose wins =
116+
([],) <$> do
117+
ibData <- lift $ atomically $ buffers.newIBData
118+
forM [toEnum $ fromIntegral sub | sub <- [0 .. wins - 1]] $ \sub -> do
119+
i <- nextBlkId InputBlockId
120+
let header = mkInputBlockHeader leios i slot sub nodeId ibData.referenceRankingBlock
121+
return $! mkInputBlock leios header ibData.txsPayload
122+
execute' slot Endorse _wins =
123+
([],) <$> do
124+
i <- nextBlkId EndorseBlockId
125+
ibs <- lift $ atomically $ buffers.ibs
126+
return $! mkEndorseBlock leios i slot nodeId $ inputBlocksToEndorse leios slot ibs
127+
execute' slot Vote votes =
128+
([],) <$> do
129+
votingFor <- lift $ atomically $ do
130+
ibs <- buffers.ibs
131+
ebs <- buffers.ebs
132+
pure $ endorseBlocksToVoteFor leios slot ibs ebs
133+
i <- nextBlkId VoteId
134+
return $! mkVoteMsg leios i slot nodeId votes votingFor
126135
nextBlkId :: (NodeId -> Int -> a) -> StateT Int m a
127136
nextBlkId f = do
128137
i <- get

‎simulation/src/LeiosProtocol/Short/Node.hs

+18-14
Original file line numberDiff line numberDiff line change
@@ -455,6 +455,7 @@ validationDispatcher tracer cfg leiosState = forever $ do
455455
where
456456
traceEnterState :: [a] -> (a -> LeiosEventBlock) -> m ()
457457
traceEnterState xs f = forM_ xs $ traceWith tracer . LeiosNodeEvent EnterState . f
458+
458459
generator ::
459460
forall m.
460461
(MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m) =>
@@ -466,21 +467,24 @@ generator tracer cfg st = do
466467
schedule <- mkSchedule cfg
467468
let buffers = mkBuffersView cfg st
468469
let
469-
submitOne :: SomeAction -> m ()
470-
submitOne x = case x of
471-
SomeAction Generate.Base rb -> do
472-
atomically $ addProducedBlock st.praosState.blockFetchControllerState rb
473-
traceWith tracer (PraosNodeEvent (PraosNodeEventGenerate rb))
474-
SomeAction Generate.Propose ibs -> forM_ ibs $ \ib -> do
475-
atomically $ modifyTVar' st.relayIBState.relayBufferVar (RB.snoc ib.header.id (ib.header, ib.body))
476-
traceWith tracer (LeiosNodeEvent Generate (EventIB ib))
477-
SomeAction Generate.Endorse eb -> do
478-
atomically $ modifyTVar' st.relayEBState.relayBufferVar (RB.snoc eb.id (eb.id, eb))
479-
traceWith tracer (LeiosNodeEvent Generate (EventEB eb))
480-
SomeAction Generate.Vote v -> do
481-
atomically $ modifyTVar' st.relayVoteState.relayBufferVar (RB.snoc v.id (v.id, v))
482-
traceWith tracer (LeiosNodeEvent Generate (EventVote v))
470+
submitOne :: ([CPUTask], SomeAction) -> m ()
471+
submitOne (delays, x) = do
472+
threadDelayParallel tracer (coerce delays)
473+
case x of
474+
SomeAction Generate.Base rb -> do
475+
atomically $ addProducedBlock st.praosState.blockFetchControllerState rb
476+
traceWith tracer (PraosNodeEvent (PraosNodeEventGenerate rb))
477+
SomeAction Generate.Propose ibs -> forM_ ibs $ \ib -> do
478+
atomically $ modifyTVar' st.relayIBState.relayBufferVar (RB.snoc ib.header.id (ib.header, ib.body))
479+
traceWith tracer (LeiosNodeEvent Generate (EventIB ib))
480+
SomeAction Generate.Endorse eb -> do
481+
atomically $ modifyTVar' st.relayEBState.relayBufferVar (RB.snoc eb.id (eb.id, eb))
482+
traceWith tracer (LeiosNodeEvent Generate (EventEB eb))
483+
SomeAction Generate.Vote v -> do
484+
atomically $ modifyTVar' st.relayVoteState.relayBufferVar (RB.snoc v.id (v.id, v))
485+
traceWith tracer (LeiosNodeEvent Generate (EventVote v))
483486
let LeiosNodeConfig{..} = cfg
487+
-- TODO: more parallelism `mapM_ submitOne` will make each later submission wait.
484488
blockGenerator $ BlockGeneratorConfig{submit = mapM_ submitOne, ..}
485489

486490
mkBuffersView :: forall m. MonadSTM m => LeiosNodeConfig -> LeiosNodeState m -> BuffersView m

‎simulation/src/LeiosProtocol/Short/Sim.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -107,7 +107,7 @@ traceRelayLink1 tcpprops =
107107
, -- \^ hash matching and payload validation (incl. tx scripts)
108108
endorseBlockValidation = const 0.005
109109
, voteMsgValidation = const 0.005
110-
, certificateCreation = const 0.050 -- TODO: is this used?
110+
, certificateCreation = const 0.050
111111
}
112112
}
113113
let leiosNodeConfig nodeId@(NodeId i) =

‎simulation/src/LeiosProtocol/Short/SimP2P.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -182,7 +182,7 @@ exampleLeiosConfig slotConfig = leios
182182
, inputBlockValidation = const 0.1
183183
, endorseBlockValidation = const 0.005
184184
, voteMsgValidation = const 0.005
185-
, certificateCreation = const 0.050 -- TODO: is this used?
185+
, certificateCreation = const 0.050
186186
}
187187

188188
praos =

0 commit comments

Comments
 (0)