simulation: handle NumCores in praosNode

Author: Saizan

simulation/ouroboros-leios-sim.cabal

@@ -61,7 +61,6 @@ library
     LeiosProtocol.Short.VizSim
     LeiosProtocol.Short.VizSimP2P
     LeiosProtocol.SimTestRelay
-    LeiosProtocol.TaskMultiQueue
     LeiosProtocol.VizSimTestRelay
     ModelTCP
     JSONCompat
@@ -91,6 +90,7 @@ library
     STMCompat
     SimTCPLinks
     SimTypes
+    TaskMultiQueue
     TimeCompat
     Topology
     Viz

simulation/src/LeiosProtocol/Short/Generate.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -14,16 +15,13 @@ import Control.Monad (forM)
 import Control.Monad.State (
   MonadState (get, put),
   MonadTrans (lift),
-  StateT (runStateT),
-  gets,
-  runState,
+  StateT,
  )
 import Data.Bifunctor (Bifunctor (..))
 import Data.Kind (Type)
 import LeiosProtocol.Common
 import LeiosProtocol.Short hiding (Stage (..))
 import STMCompat
-import System.Random (StdGen, uniformR)
 
 --------------------------------------------------------------------------------
 
@@ -50,42 +48,7 @@ data SomeRole :: Type where
 data SomeAction :: Type where
   SomeAction :: Role a -> a -> SomeAction
 
-mkScheduler :: MonadSTM m => StdGen -> (SlotNo -> [(a, Maybe (Double -> Word64))]) -> m (SlotNo -> m [(a, Word64)])
-mkScheduler rng0 rates = do
-  let
-    sampleRates (_role, Nothing) = return []
-    sampleRates (role, Just f) = do
-      (sample, rng') <- gets $ uniformR (0, 1)
-      put $! rng'
-      let wins = f sample
-      return [(role, wins) | wins >= 1]
-  rngVar <- newTVarIO rng0
-  let sched slot = atomically $ do
-        rng <- readTVar rngVar
-        let (acts, rng1) = flip runState rng . fmap concat . mapM sampleRates $ rates slot
-        writeTVar rngVar rng1
-        return acts
-  return sched
-
--- | @waitNextSlot cfg targetSlot@ waits until the beginning of
--- @targetSlot@ if that's now or in the future, otherwise the closest slot.
-waitNextSlot :: (Monad m, MonadTime m, MonadDelay m) => SlotConfig -> SlotNo -> m SlotNo
-waitNextSlot slotConfig targetSlot = do
-  now <- getCurrentTime
-  let targetSlotTime = slotTime slotConfig targetSlot
-  let slot
-        | now <= targetSlotTime = targetSlot
-        | otherwise = assert (nextSlotIndex >= 0) $ toEnum nextSlotIndex
-       where
-        nextSlotIndex =
-          assert (slotConfig.duration == 1) $
-            ceiling $
-              now `diffUTCTime` slotConfig.start
-  let tgt = slotTime slotConfig slot
-  threadDelayNDT (tgt `diffUTCTime` now)
-  return slot
-
-data BlockGeneratorConfig m = BlockGeneratorConfig
+data LeiosGeneratorConfig m = LeiosGeneratorConfig
   { leios :: LeiosConfig
   , slotConfig :: SlotConfig
   , nodeId :: NodeId
@@ -94,19 +57,21 @@ data BlockGeneratorConfig m = BlockGeneratorConfig
   , submit :: [(DiffTime, SomeAction)] -> m ()
   }
 
-blockGenerator ::
+leiosBlockGenerator ::
   forall m.
   (MonadSTM m, MonadDelay m, MonadTime m) =>
-  BlockGeneratorConfig m ->
+  LeiosGeneratorConfig m ->
   m ()
-blockGenerator BlockGeneratorConfig{..} = go (0, 0)
+leiosBlockGenerator LeiosGeneratorConfig{..} =
+  blockGenerator $
+    BlockGeneratorConfig
+      { execute = \slot -> do
+          roles <- lift $ schedule slot
+          actions <- concat <$> mapM (execute slot) roles
+          lift $ submit actions
+      , slotConfig
+      }
  where
-  go (!blkId, !tgtSlot) = do
-    slot <- waitNextSlot slotConfig tgtSlot
-    roles <- schedule slot
-    (actions, blkId') <- runStateT (concat <$> mapM (execute slot) roles) blkId
-    submit actions
-    go (blkId', slot + 1)
   execute slot (SomeRole r, wins) = assert (wins >= 1) $ (map . second) (SomeAction r) <$> execute' slot r wins
   execute' :: SlotNo -> Role a -> Word64 -> StateT Int m [(DiffTime, a)]
   execute' slot Base _wins = do

simulation/src/LeiosProtocol/Short/Node.hs

@@ -24,7 +24,7 @@ import Control.Monad.Class.MonadThrow
 import Control.Tracer
 import Data.Coerce (coerce)
 import Data.Foldable (forM_)
-import Data.Ix (Ix, range)
+import Data.Ix (Ix)
 import Data.List (sort, sortOn)
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
@@ -39,7 +39,6 @@ import qualified LeiosProtocol.RelayBuffer as RB
 import LeiosProtocol.Short
 import LeiosProtocol.Short.Generate
 import qualified LeiosProtocol.Short.Generate as Generate
-import LeiosProtocol.TaskMultiQueue
 import Numeric.Natural (Natural)
 import PraosProtocol.BlockFetch (
   BlockFetchControllerState (blocksVar),
@@ -51,7 +50,7 @@ import qualified PraosProtocol.PraosNode as PraosNode
 import STMCompat
 import SimTypes (cpuTask)
 import System.Random
-import WorkerPool
+import TaskMultiQueue
 
 --------------------------------------------------------------
 ---- Events
@@ -99,9 +98,9 @@ data LeiosNodeState m = LeiosNodeState
   , relayVoteState :: !(RelayVoteState m)
   , ibDeliveryTimesVar :: !(TVar m (Map InputBlockId UTCTime))
   , taskQueue :: !(TaskMultiQueue LeiosNodeTask m)
-  , waitingForRBVar :: !(TVar m (Map (HeaderHash RankingBlock) [m ()]))
+  , waitingForRBVar :: !(TVar m (Map (HeaderHash RankingBlock) [STM m ()]))
   -- ^ waiting for RB block itself to be validated.
-  , waitingForLedgerStateVar :: !(TVar m (Map (HeaderHash RankingBlock) [m ()]))
+  , waitingForLedgerStateVar :: !(TVar m (Map (HeaderHash RankingBlock) [STM m ()]))
   -- ^ waiting for ledger state of RB block to be validated.
   , ledgerStateVar :: !(TVar m (Map (HeaderHash RankingBlock) LedgerState))
   , ibsNeededForEBVar :: !(TVar m (Map EndorseBlockId (Set InputBlockId)))
@@ -400,25 +399,6 @@ leiosNode tracer cfg followers peers = do
       , pruningThreads
       ]
 
-processCPUTasks ::
-  (MonadSTM m, MonadDelay m, MonadMonotonicTimeNSec m, MonadFork m, MonadAsync m, MonadCatch m) =>
-  NumCores ->
-  Tracer m CPUTask ->
-  TaskMultiQueue LeiosNodeTask m ->
-  m ()
-processCPUTasks Infinite tracer queue = forever $ runInfParallelBlocking tracer queue
-processCPUTasks (Finite n) tracer queue = newBoundedWorkerPool n [taskSource l | l <- range (minBound, maxBound)]
- where
-  taskSource l = do
-    (cpu, m) <- readTMQueue queue l
-    var <- newEmptyTMVar
-    let action = do
-          traceWith tracer cpu
-          threadDelay (cpuTaskDuration cpu)
-          m
-    -- TODO: read from var and log exception.
-    return $ Task action var
-
 computeLedgerStateThread ::
   forall m.
   (MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m) =>
@@ -456,7 +436,7 @@ dispatchValidation ::
 dispatchValidation tracer cfg leiosState req =
   atomically $ mapM_ (uncurry $ writeTMQueue leiosState.taskQueue) =<< go req
  where
-  queue = atomically . mapM_ (uncurry $ writeTMQueue leiosState.taskQueue)
+  queue = mapM_ (uncurry $ writeTMQueue leiosState.taskQueue)
   labelTask (tag, (f, m)) = let !task = f (show tag) in (tag, (task, m))
   valRB rb m = do
     let task prefix = cpuTask prefix cfg.leios.praos.blockValidationDelay rb
@@ -561,7 +541,7 @@ generator tracer cfg st = do
           atomically $ modifyTVar' st.relayVoteState.relayBufferVar (RB.snoc v.id (v.id, v))
           traceWith tracer (LeiosNodeEvent Generate (EventVote v))
   let LeiosNodeConfig{..} = cfg
-  blockGenerator $ BlockGeneratorConfig{submit = mapM_ submitOne, ..}
+  leiosBlockGenerator $ LeiosGeneratorConfig{submit = mapM_ submitOne, ..}
 
 mkBuffersView :: forall m. MonadSTM m => LeiosNodeConfig -> LeiosNodeState m -> BuffersView m
 mkBuffersView cfg st = BuffersView{..}

simulation/src/PraosProtocol/BlockFetch.hs

@@ -26,9 +26,8 @@ import Chan (Chan)
 import ChanDriver (ProtocolMessage, chanDriver)
 import Control.Exception (assert)
 import Control.Monad (forM, forever, guard, join, unless, void, when, (<=<))
-import Control.Tracer (Contravariant (contramap), Tracer, traceWith)
+import Control.Tracer (Tracer, traceWith)
 import Data.Bifunctor (second)
-import Data.Foldable (forM_)
 import Data.Kind (Type)
 import qualified Data.List as List
 import Data.Map.Strict (Map)
@@ -47,7 +46,6 @@ import Network.TypedProtocol (
 import Network.TypedProtocol.Driver (runPeerWithDriver)
 import qualified Network.TypedProtocol.Peer.Client as TC
 import qualified Network.TypedProtocol.Peer.Server as TS
-import Numeric.Natural (Natural)
 import PraosProtocol.Common
 import qualified PraosProtocol.Common.AnchoredFragment as AnchoredFragment
 import qualified PraosProtocol.Common.Chain as Chain
@@ -602,82 +600,30 @@ initBlockFetchConsumerStateForPeerId tracer peerId blockFetchControllerState sub
 
 setupValidatorThreads ::
   (MonadSTM m, MonadDelay m) =>
-  Tracer m (PraosNodeEvent BlockBody) ->
   PraosConfig BlockBody ->
   BlockFetchControllerState BlockBody m ->
-  -- | bound on queue length.
-  Natural ->
+  ((CPUTask, m ()) -> STM m ()) ->
   m ([m ()], Block BlockBody -> m () -> m ())
-setupValidatorThreads tracer cfg st n = do
-  queue <- newTBQueueIO n
-  (waitingVar, processWaitingThread) <- setupProcessWaitingThread (contramap PraosNodeEventCPU tracer) (Just 1) st.blocksVar
-  let doTask (cpuTask, m) = do
-        traceWith tracer . PraosNodeEventCPU $ cpuTask
-        threadDelay cpuTask.cpuTaskDuration
-        m
-
-  -- if we have the previous block, we process the task sequentially to provide back pressure on the queue.
-  let waitForPrev block task = case blockPrevHash block of
-        GenesisHash -> doTask task
+setupValidatorThreads cfg st queue = do
+  waitingVar <- newTVarIO Map.empty
+  let processWaitingThread = processWaiting' st.blocksVar waitingVar
+
+  let waitForPrev block task = atomically $ case blockPrevHash block of
+        GenesisHash -> queue task
         BlockHash prev -> do
-          havePrev <- Map.member prev <$> readTVarIO st.blocksVar
-          -- Note: for pure praos this also means we have the ledger state.
-          if havePrev
-            then doTask task
-            else atomically $ modifyTVar' waitingVar (Map.insertWith (++) prev [task])
-      fetch = forever $ do
-        (block, completion) <- atomically $ readTBQueue queue
+          modifyTVar' waitingVar (Map.insertWith (++) prev [queue task])
+      add block completion = do
         assert (blockInvariant block) $ do
           waitForPrev block $
             let !cpuTask = CPUTask (cfg.blockValidationDelay block) (T.pack $ "Validate " ++ show (blockHash block))
              in (cpuTask, completion)
-      add block completion = atomically $ writeTBQueue queue (block, completion)
-  return ([fetch, processWaitingThread], add)
-
-setupProcessWaitingThread ::
-  forall m a b.
-  (MonadSTM m, MonadDelay m) =>
-  Tracer m CPUTask ->
-  -- | how many waiting to process in parallel
-  Maybe Int ->
-  TVar m (Map ConcreteHeaderHash a) ->
-  m (TVar m (Map ConcreteHeaderHash [(CPUTask, m b)]), m ())
-setupProcessWaitingThread tracer npar blocksVar = do
-  waitingVar <- newTVarIO Map.empty
-  return (waitingVar, processWaiting tracer npar blocksVar waitingVar)
-
-processWaiting ::
-  forall m a b.
-  (MonadSTM m, MonadDelay m) =>
-  Tracer m CPUTask ->
-  -- | how many waiting to process in parallel
-  Maybe Int ->
-  TVar m (Map ConcreteHeaderHash a) ->
-  TVar m (Map ConcreteHeaderHash [(CPUTask, m b)]) ->
-  m ()
-processWaiting tracer npar blocksVar waitingVar = go
- where
-  parallelDelay xs = do
-    let !d = maximum $ map (cpuTaskDuration . fst) xs
-    forM_ xs $ traceWith tracer . fst
-    threadDelay d
-    mapM_ snd xs
-  go = forever $ join $ atomically $ do
-    waiting <- readTVar waitingVar
-    when (Map.null waiting) retry
-    blocks <- readTVar blocksVar
-    let toValidate = Map.intersection waiting blocks
-    when (Map.null toValidate) retry
-    writeTVar waitingVar $! waiting Map.\\ toValidate
-    let chunks Nothing xs = [xs]
-        chunks (Just m) xs = map (take m) . takeWhile (not . null) . iterate (drop m) $ xs
-    return . mapM_ parallelDelay . chunks npar . concat . Map.elems $ toValidate
+  return ([processWaitingThread], add)
 
 processWaiting' ::
   forall m a b.
   (MonadSTM m, MonadDelay m) =>
   TVar m (Map ConcreteHeaderHash a) ->
-  TVar m (Map ConcreteHeaderHash [m b]) ->
+  TVar m (Map ConcreteHeaderHash [STM m b]) ->
   m ()
 processWaiting' blocksVar waitingVar = go
  where
@@ -688,4 +634,4 @@ processWaiting' blocksVar waitingVar = go
     let toValidate = Map.intersection waiting blocks
     when (Map.null toValidate) retry
     writeTVar waitingVar $! waiting Map.\\ toValidate
-    return . sequence_ . concat . Map.elems $ toValidate
+    return . mapM_ atomically . concat . Map.elems $ toValidate