From e54a7c78148313f959a3e703209e6e43f558bd4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 15 Jan 2026 10:23:23 +0100 Subject: [PATCH 01/16] Allow application to burst a sequence of sdu's --- network-mux/bench/socket_read_write/Main.hs | 4 +- network-mux/demo/mux-demo.hs | 3 +- network-mux/demo/mux-leios-demo.hs | 3 +- network-mux/network-mux.cabal | 1 + network-mux/src/Network/Mux.hs | 19 ++- network-mux/src/Network/Mux/Egress.hs | 141 ++++++++++++++++---- network-mux/src/Network/Mux/Types.hs | 17 ++- network-mux/test/Test/Mux.hs | 12 +- 8 files changed, 153 insertions(+), 47 deletions(-) diff --git a/network-mux/bench/socket_read_write/Main.hs b/network-mux/bench/socket_read_write/Main.hs index 02a9262ceda..d2b5f2736a9 100644 --- a/network-mux/bench/socket_read_write/Main.hs +++ b/network-mux/bench/socket_read_write/Main.hs @@ -144,7 +144,7 @@ mkMiniProtocolState num = do mpv <- newTVarIO StatusRunning let mpi = MiniProtocolInfo (MiniProtocolNum num) InitiatorDirectionOnly - (MiniProtocolLimits maxBound) Nothing + (MiniProtocolLimits maxBound Nothing) Nothing return $ MiniProtocolState mpi mpq mpv -- | Run a server that accept connections on `ad`. @@ -253,7 +253,7 @@ startServerEgresss pollInterval sndSizeV ad = forever $ do let wasEmpty = BL.null buf writeTVar w (BL.append buf msg) when wasEmpty $ - writeTBQueue eq (TLSRDemand mc md $ Wanton w) + writeTBQueue eq (TLSRDemand mc md (Wanton w) $ ProtocolBurst 1) else retry setupServer :: Socket -> IO Socket.SockAddr diff --git a/network-mux/demo/mux-demo.hs b/network-mux/demo/mux-demo.hs index ab63ce3bf60..6acb8a43c95 100644 --- a/network-mux/demo/mux-demo.hs +++ b/network-mux/demo/mux-demo.hs @@ -81,7 +81,8 @@ debugTracer = show >$< Tracer putStrLn_ defaultProtocolLimits :: MiniProtocolLimits defaultProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = 64_000 + maximumIngressQueue = 64_000, + burst = Nothing } -- diff --git a/network-mux/demo/mux-leios-demo.hs b/network-mux/demo/mux-leios-demo.hs index 8dd7ca05677..528b4a01e9d 100644 --- a/network-mux/demo/mux-leios-demo.hs +++ b/network-mux/demo/mux-leios-demo.hs @@ -115,7 +115,8 @@ reqrespTracer tag = Tracer $ \case defaultProtocolLimits :: MiniProtocolLimits defaultProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = 10_000_000 + maximumIngressQueue = 10_000_000, + burst = Nothing } diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 76b152d0e0f..5fb51ed3757 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -67,6 +67,7 @@ library statistics-linreg >=0.3 && <0.4, strict, time >=1.9.1 && <1.16, + transformers, vector >=0.12 && <0.14, if os(windows) diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 8df0b266f50..3cda51b1aad 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -66,7 +66,7 @@ import Data.ByteString.Lazy qualified as BL import Data.Int (Int64) import Data.Map (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (isNothing) +import Data.Maybe (fromMaybe, isNothing) import Data.Monoid.Synchronisation (FirstToFinish (..)) import Data.Strict.Tuple (pattern (:!:)) @@ -78,6 +78,7 @@ import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI (Time (..)) import Control.Monad.Class.MonadTimer.SI hiding (timeout) import Control.Tracer @@ -312,7 +313,8 @@ miniProtocolJob TracersI { miniProtocolInfo = MiniProtocolInfo { miniProtocolNum, - miniProtocolDir + miniProtocolDir, + miniProtocolLimits }, miniProtocolIngressQueue, miniProtocolStatusVar @@ -328,9 +330,11 @@ miniProtocolJob TracersI { where jobAction = do w <- newTVarIO BL.empty - let chan = muxChannel channelTracer_ egressQueue (Wanton w) + lastSent <- newTVarIO (Time 0) + bucket <- newTVarIO 0 + let chan = muxChannel channelTracer_ egressQueue (Wanton w lastSent bucket) miniProtocolNum miniProtocolDirEnum - miniProtocolIngressQueue + miniProtocolIngressQueue (burst miniProtocolLimits) (result, remainder) <- miniProtocolAction chan traceWith tracer_ (TraceTerminating miniProtocolNum miniProtocolDirEnum) atomically $ do @@ -676,8 +680,9 @@ muxChannel -> MiniProtocolNum -> MiniProtocolDir -> IngressQueue m + -> Maybe ProtocolBurst -> ByteChannel m -muxChannel tracer egressQueue want@(Wanton w) mc md q = +muxChannel tracer egressQueue want@(Wanton w _ _) mc md q mBurst = Channel { send, recv } where -- A soft limit on the egress buffer (Wanton) size. @@ -690,6 +695,8 @@ muxChannel tracer egressQueue want@(Wanton w) mc md q = egressSoftBufferLimit :: Int64 egressSoftBufferLimit = 0x3ffff + burst = fromMaybe (ProtocolBurst 0 0) mBurst + send :: BL.ByteString -> m () send encoding = do -- We send CBOR encoded messages by encoding them into by ByteString @@ -704,7 +711,7 @@ muxChannel tracer egressQueue want@(Wanton w) mc md q = let wasEmpty = BL.null buf writeTVar w (BL.append buf encoding) when wasEmpty $ - writeTBQueue egressQueue (TLSRDemand mc md want) + writeTBQueue egressQueue (TLSRDemand mc md want burst) else retry traceWith tracer $ TraceChannelSendEnd mc diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index ef8fcd5b769..b264e37212e 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -1,8 +1,12 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Network.Mux.Egress @@ -14,8 +18,13 @@ module Network.Mux.Egress , Wanton (..) ) where +import Control.Exception import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Data.Bool import Data.ByteString.Lazy qualified as BL +import Data.Word (Word32) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync @@ -121,12 +130,18 @@ type EgressQueue m = StrictTBQueue m (TranslocationServiceRequest m) -- responsible for the segmentation of concrete representation into -- appropriate SDU's for onward transmission. data TranslocationServiceRequest m = - TLSRDemand !MiniProtocolNum !MiniProtocolDir !(Wanton m) + TLSRDemand !MiniProtocolNum !MiniProtocolDir !(Wanton m) !ProtocolBurst -- | A Wanton represent the concrete data to be translocated, note that the -- TVar becoming empty indicates -- that the last fragment of the data has -- been enqueued on the -- underlying bearer. -newtype Wanton m = Wanton { want :: StrictTVar m BL.ByteString } +data Wanton m = Wanton { + want :: !(StrictTVar m BL.ByteString), + wLastSent :: !(StrictTVar m Time), + -- ^ the last time the protocol has sent a message + wBucket :: !(StrictTVar m Word32) + -- ^ the number of tokens available to burst + } -- | Process the messages from the mini protocols - there is a single @@ -150,9 +165,18 @@ muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval withTimeoutSerial $ \timeout -> forever $ do start <- getMonotonicTime - TLSRDemand mpc md d <- atomically $ readTBQueue egressQueue - sdu <- processSingleWanton egressQueue sduSize mpc md d - sdus <- buildBatch [sdu] (sduLength sdu) + (sdu, mBurst) <- atomically do + demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate)) <- readTBQueue egressQueue + eSdu <- processSingleWanton sduSize mpc md d + case eSdu of + Right sdu | pbMaxBytes > 0 -> do + -- we do not check if the protocol has any tokens to burst, + -- that is deferred to buildBatch below. + (sdu, True) <$ unGetTBQueue egressQueue demand + | otherwise -> (sdu, False) <$ writeTBQueue egressQueue demand + Left sdu -> pure (sdu, False) + + sdus <- buildBatch [sdu] (sduLength sdu) mBurst start void $ writeMany tracer timeout sdus end <- getMonotonicTime empty <- atomically $ isEmptyTBQueue egressQueue @@ -168,51 +192,110 @@ muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval sduLength sdu = fromIntegral msHeaderLength + fromIntegral (msLength sdu) -- Build a batch of SDUs to submit in one go to the bearer. - -- The egress queue is still processed one SDU at the time - -- to ensure that we don't cause starvation. + -- Streams which are permitted to burst will have that many + -- sdu's serviced back-to-back before the scheduler moves to process the + -- next request on the queue. Any remaining sdu's which did not + -- fit in the burst allowance are placed on the back of the queue + -- to ensure that we don't cause starvation. In particular, a burst + -- of 1 will have the muxer process one sdu at a time from the queue, + -- and any remaining work is put on the back of the queue. -- The batch size is either limited by the bearer -- (e.g the SO_SNDBUF for Socket) or number of SDUs. -- - buildBatch s sl = reverse <$> go s sl + buildBatch s sl mBurst0 start = reverse <$> go 1 s sl mBurst0 where - go sdus _ | length sdus >= maxSDUsPerBatch = return sdus - go sdus sdusLength | sdusLength >= batchSize = return sdus - go sdus !sdusLength = do - demand_m <- atomically $ tryReadTBQueue egressQueue - case demand_m of - Just (TLSRDemand mpc md d) -> do - sdu <- processSingleWanton egressQueue sduSize mpc md d - go (sdu:sdus) (sdusLength + sduLength sdu) - Nothing -> return sdus + toDouble :: DiffTime -> Double + toDouble = realToFrac + + go !count sdus _ _ | count >= maxSDUsPerBatch = return sdus + go _ sdus sdusLength _ | sdusLength >= batchSize = return sdus + go count sdus !sdusLength mBurst = do + mResult <- atomically $ tryReadTBQueue egressQueue + case mResult of + Nothing -> return sdus + Just demand@(TLSRDemand mpc md d@Wanton { wLastSent, wBucket } (ProtocolBurst pbMaxBytes pbRefillRate)) -> do + (count', sdusLength', sdus') <- atomically do + delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) + isEmpty <- isEmptyTBQueue egressQueue + let boundedTokens = min sduSize . fromIntegral . min (fromIntegral $ maxBound @SDUSize) + sduSize0 <- stateTVar wBucket \tokens -> + let tokens' = truncate $ + min (fromIntegral pbMaxBytes) + (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) + -- we leverage burst and deduct credits only where there is contention + -- between protocols + sduSize0 = bool (Left sduSize) (Right $ boundedTokens tokens') (mBurst && not isEmpty) + in (sduSize0, tokens') + let step (!count', !sdusLength', !sdus', !eSize) mx = do + -- the first one is always free + -- For Left's, we don't count the wanton bytes against the burst allowance + -- to permit a full sdu in the first iteration + let (size, consumedTokens) = either (, const 0) (, id) eSize + x <- lift $ mx size + case x of + Left sdu -> do + lift $ modifyTVar wBucket \tokens -> + let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) + in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) + tokens' + let sdusLength'' = sdusLength' + sduLength sdu + throwE (succ count', sdusLength'', sdu:sdus') + Right sdu -> do + nextSdu <- lift $ stateTVar wBucket \tokens -> + let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) + in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) + (boundedTokens tokens', tokens') + let sdusLength'' = sdusLength' + sduLength sdu + count'' = succ count' + if | nextSdu <= 400 -> do -- 8 bytes header / 2% burst efficiency + -- there is more payload, but burst allowance has been exhausted + lift $ writeTBQueue egressQueue demand + throwE (count'', sdusLength'', sdu:sdus') + | sdusLength'' >= batchSize || count'' >= maxSDUsPerBatch -> do + lift $ unGetTBQueue egressQueue demand + throwE (count'', sdusLength'', sdu:sdus') + | otherwise -> pure (count'', sdusLength'', sdu:sdus', Right nextSdu) + either pure (\(a, b, c, _d) -> (a, b, c) <$ writeTBQueue egressQueue demand) + =<< runExceptT do + when (either id id sduSize0 <= 400) do + -- edge case where the protocol is bursty, but there aren't enough tokens + -- available. The muxer forever loop does not check this + -- when it calls to build a batch, so we handle it here. + lift $ writeTBQueue egressQueue demand + throwE (count, sdusLength, sdus) + foldM step (count, sdusLength, sdus, sduSize0) + (if isEmpty + then [const $ processSingleWanton sduSize mpc md d] + -- ^ grab full sdu, save the tokens for cases with contention + else repeat (\sduSize' -> processSingleWanton sduSize' mpc md d)) + go count' sdus' sdusLength' False + -- | Pull a `maxSDU`s worth of data out out the `Wanton` - if there is -- data remaining requeue the `TranslocationServiceRequest` (this -- ensures that any other items on the queue will get some service -- first. -processSingleWanton :: MonadSTM m - => EgressQueue m - -> SDUSize +processSingleWanton :: (MonadSTM m) + => SDUSize -> MiniProtocolNum -> MiniProtocolDir -> Wanton m - -> m SDU -processSingleWanton egressQueue (SDUSize sduSize) + -- Right: more sdu's remain; Left: finished + -> STM m (Either SDU SDU) +processSingleWanton sduSize mpc md wanton = do - blob <- atomically $ do + (blob, wrap) <- do -- extract next SDU d <- readTVar (want wanton) let (frag, rest) = BL.splitAt (fromIntegral sduSize) d -- if more to process then enqueue remaining work if BL.null rest - then writeTVar (want wanton) BL.empty + then (frag, Left) <$ writeTVar (want wanton) BL.empty else do -- Note that to preserve bytestream ordering within a given -- miniprotocol the readTVar and writeTVar operations -- must be inside the same STM transaction. - writeTVar (want wanton) rest - writeTBQueue egressQueue (TLSRDemand mpc md wanton) - -- return data to send - pure frag + (frag, Right) <$ writeTVar (want wanton) rest let sdu = SDU { msHeader = SDUHeader { mhTimestamp = RemoteClockModel 0, @@ -222,5 +305,5 @@ processSingleWanton egressQueue (SDUSize sduSize) }, msBlob = blob } - return sdu + pure $ wrap sdu --paceTransmission tNow diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs index 00fd1e47dcc..db863da810e 100644 --- a/network-mux/src/Network/Mux/Types.hs +++ b/network-mux/src/Network/Mux/Types.hs @@ -25,6 +25,7 @@ module Network.Mux.Types , IngressQueue , MiniProtocolIx , MiniProtocolDir (..) + , ProtocolBurst (..) , protocolDirEnum , MiniProtocolState (..) , MiniProtocolStatus (..) @@ -93,15 +94,25 @@ newtype MiniProtocolNum = MiniProtocolNum Word16 deriving (Eq, Ord, Enum, Ix, Show) -- | Per Miniprotocol limits -newtype MiniProtocolLimits = +data MiniProtocolLimits = MiniProtocolLimits { -- | Limit on the maximum number of bytes that can be queued in the -- miniprotocol's ingress queue. -- - maximumIngressQueue :: Int + maximumIngressQueue :: !Int, + burst :: !(Maybe ProtocolBurst) } deriving Show + +data ProtocolBurst = ProtocolBurst { + pbMaxBytes :: !Word32, + -- ^ token bucket max size + pbRefillRate :: !Word32 + -- ^ token bucket refill rate, [1/s] + } + deriving (Eq, Show) + -- $interface -- -- To run a node you will also need a bearer and a way to run a server, see @@ -287,7 +298,7 @@ newtype SDUSize = SDUSize { getSDUSize :: Word16 } deriving Generic deriving Show via Quiet SDUSize deriving (Eq, Ord, Enum) - deriving (Num, Real, Integral) + deriving (Bounded, Num, Real, Integral) -- | A channel which wraps each message as an 'SDU' using giving -- 'MiniProtocolNum' and 'MiniProtocolDir'. diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index 8b7627b4112..eb6932c187b 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -116,7 +116,8 @@ tests = defaultMiniProtocolLimits :: MiniProtocolLimits defaultMiniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit + maximumIngressQueue = defaultMiniProtocolLimit, + burst = Nothing } defaultMiniProtocolLimit :: Int @@ -125,7 +126,8 @@ defaultMiniProtocolLimit = 3000000 smallMiniProtocolLimits :: MiniProtocolLimits smallMiniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = smallMiniProtocolLimit + maximumIngressQueue = smallMiniProtocolLimit, + burst = Nothing } smallMiniProtocolLimit :: Int @@ -2016,7 +2018,7 @@ close_experiment [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolCapability = Nothing } ]) @@ -2036,7 +2038,7 @@ close_experiment [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolCapability = Nothing } ]) @@ -2395,7 +2397,7 @@ prop_mux_trailing_bytes reminder (NonEmptyByteString received) = do [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolCapability = Nothing } ] From ecd2b065c9a162e5d74e513a92150eeadf059a4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 19 Mar 2026 10:41:12 +0100 Subject: [PATCH 02/16] Support for weighted fair queuing --- network-mux/src/Network/Mux.hs | 57 ++-- network-mux/src/Network/Mux/Egress.hs | 244 +++++++++++------- network-mux/src/Network/Mux/Types.hs | 6 +- .../framework/lib/Ouroboros/Network/Mux.hs | 9 +- 4 files changed, 199 insertions(+), 117 deletions(-) diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 3cda51b1aad..2db12578e98 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -66,9 +66,10 @@ import Data.ByteString.Lazy qualified as BL import Data.Int (Int64) import Data.Map (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, isNothing) -import Data.Monoid.Synchronisation (FirstToFinish (..)) +import Data.Maybe (fromMaybe) +import Data.Monoid.Synchronisation (FirstToFinish (..), LastToFinish (..)) import Data.Strict.Tuple (pattern (:!:)) +import Data.Word (Word8) import Control.Applicative import Control.Concurrent.Class.MonadSTM.Strict @@ -227,10 +228,10 @@ run :: forall m (mode :: Mode). , MonadEvaluate m , MonadFork m , MonadLabelledSTM m - , Alternative (STM m) , MonadThrow (STM m) , MonadTimer m , MonadMask m + , MonadPlus (STM m) ) => Mux mode m -> Bearer m @@ -246,16 +247,27 @@ run Mux { muxMiniProtocols, bearer@Bearer{name} = do traceWith tracer_ TraceStarting - egressQueue <- atomically $ newTBQueue 100 + + let step mMap MiniProtocolState { miniProtocolInfo } = do + let weight = miniProtocolWeight miniProtocolInfo + Map.alterF (\case + Nothing -> do + q <- newTBQueue 100 + labelTBQueue q (name ++ "-mux-egress-" ++ show weight) + pure $ Just q + pass -> pure pass) + weight + =<< mMap + egressQueues <- atomically $ Map.foldl step (pure Map.empty) muxMiniProtocols -- label shared variables - labelTBQueueIO egressQueue (name ++ "-mux-egress") + labelTVarIO muxStatus (name ++ "-mux-status") labelTQueueIO muxControlCmdQueue (name ++ "-mux-ctrl") JobPool.withJobPool (\jobpool -> do - JobPool.forkJob jobpool (muxerJob egressQueue) + JobPool.forkJob jobpool (muxerJob (Map.assocs egressQueues)) JobPool.forkJob jobpool demuxerJob traceWith tracer_ (TraceState Mature) @@ -265,7 +277,7 @@ run Mux { muxMiniProtocols, monitor tracers timeout jobpool - egressQueue + egressQueues muxControlCmdQueue muxStatus ) @@ -278,8 +290,8 @@ run Mux { muxMiniProtocols, throwIO e where - muxerJob egressQueue = - JobPool.Job (muxer egressQueue bearerTracer_ bearer) + muxerJob egressQueues = + JobPool.Job (muxer egressQueues bearerTracer_ bearer) (return . MuxerException) MuxJob (name ++ "-muxer") @@ -409,13 +421,13 @@ monitor :: forall mode m. ( MonadAsync m , MonadEvaluate m , MonadMask m - , Alternative (STM m) , MonadThrow (STM m) + , MonadPlus (STM m) ) => Tracers m -> TimeoutFn m -> JobPool.JobPool Group m JobResult - -> EgressQueue m + -> Map Word8 (EgressQueue m) -> StrictTQueue m (ControlCmd mode m) -> StrictTVar m Status -> m () @@ -423,7 +435,7 @@ monitor tracers@TracersI { tracer_ = tracer, bearerTracer_ = bearerTracer } - timeout jobpool egressQueue cmdQueue muxStatus = + timeout jobpool egressQueues cmdQueue muxStatus = go (MonitorCtx Map.empty Map.empty) where go :: MonitorCtx m mode -> m () @@ -496,7 +508,8 @@ monitor tracers@TracersI { miniProtocolInfo = MiniProtocolInfo { miniProtocolNum, miniProtocolDir, - miniProtocolCapability + miniProtocolCapability, + miniProtocolWeight } } ptclAction) -> do @@ -507,14 +520,14 @@ monitor tracers@TracersI { JobPool.forkJob jobpool $ miniProtocolJob tracers - egressQueue + (egressQueues Map.! miniProtocolWeight) ptclState ptclAction Just cap -> JobPool.forkJobOn cap jobpool $ miniProtocolJob tracers - egressQueue + (egressQueues Map.! miniProtocolWeight) ptclState ptclAction go monitorCtx @@ -560,10 +573,9 @@ monitor tracers@TracersI { atomically $ writeTVar muxStatus Stopping JobPool.cancelGroup jobpool MiniProtocolJob -- wait for 2 seconds before the egress queue is drained - _ <- timeout 2 $ - atomically $ - tryPeekTBQueue egressQueue - >>= check . isNothing + _ <- timeout 2 . atomically $ + let qs = map isEmptyTBQueue (Map.elems egressQueues) + in runLastToFinish $ foldl1 (<>) (LastToFinish <$> qs) atomically $ writeTVar muxStatus Stopped traceWith tracer TraceStopped -- by exiting the 'monitor' loop we let the job pool kill demuxer and @@ -601,7 +613,8 @@ monitor tracers@TracersI { miniProtocolInfo = MiniProtocolInfo { miniProtocolNum, miniProtocolDir, - miniProtocolCapability + miniProtocolCapability, + miniProtocolWeight }, miniProtocolStatusVar } @@ -614,14 +627,14 @@ monitor tracers@TracersI { JobPool.forkJob jobpool $ miniProtocolJob tracers - egressQueue + (egressQueues Map.! miniProtocolWeight) ptclState ptclAction Just cap -> JobPool.forkJobOn cap jobpool $ miniProtocolJob tracers - egressQueue + (egressQueues Map.! miniProtocolWeight) ptclState ptclAction diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index b264e37212e..b619a824e67 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -18,13 +19,17 @@ module Network.Mux.Egress , Wanton (..) ) where +import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Except -import Data.Bool +import Control.Monad.Trans.State import Data.ByteString.Lazy qualified as BL -import Data.Word (Word32) +import Data.Either (fromRight) +import Data.List (tails) +import Data.Monoid.Synchronisation +import Data.Word (Word32, Word8) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync @@ -144,6 +149,29 @@ data Wanton m = Wanton { } +-- | A sequence of SDU's collected by the muxer to be sent to the kernel +-- in one syscall. +-- +data SDUBatch = SDUBatch { + getCount :: !Int, + -- ^ how many SDU's in the batch + getSdusLength :: !Int, + -- ^ The aggregate length of all sdu's (incl. header) + getSdus :: ![SDU] + -- ^ the payload itself + } + +instance Semigroup SDUBatch where + (SDUBatch a b c) <> (SDUBatch a' b' c') = SDUBatch (a + a') (b + b') (c <> c') + +mkSingletonBatch :: SDU -> SDUBatch +mkSingletonBatch sdu = SDUBatch 1 (sduLength sdu) [sdu] + + +sduLength :: SDU -> Int +sduLength sdu = fromIntegral msHeaderLength + fromIntegral (msLength sdu) + + -- | Process the messages from the mini protocols - there is a single -- shared FIFO that contains the items of work. This is processed so -- that each active demand gets a `maxSDU`s work of data processed @@ -156,40 +184,55 @@ muxer , MonadMask m , MonadThrow (STM m) , MonadTimer m + , Alternative (STM m) ) - => EgressQueue m + => [(Word8, EgressQueue m)] -> Tracer m BearerTrace -> Bearer m -> m void -muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval } = - withTimeoutSerial $ \timeout -> - forever $ do - start <- getMonotonicTime - (sdu, mBurst) <- atomically do - demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate)) <- readTBQueue egressQueue - eSdu <- processSingleWanton sduSize mpc md d - case eSdu of - Right sdu | pbMaxBytes > 0 -> do - -- we do not check if the protocol has any tokens to burst, - -- that is deferred to buildBatch below. - (sdu, True) <$ unGetTBQueue egressQueue demand - | otherwise -> (sdu, False) <$ writeTBQueue egressQueue demand - Left sdu -> pure (sdu, False) +muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterval } = + withTimeoutSerial $ \timeout -> (`evalStateT` cycle egressQueues0) $ forever do + egressQueues <- get + let jobs = foldMap (FirstToFinish . traverse readTBQueue) + (zip (tails egressQueues) (take numQueues (snd <$> egressQueues))) + + start <- lift getMonotonicTime + (sdu, egressQueues', burst) <- lift $ atomically do + job <- runFirstToFinish jobs + case job of + (egressQueues', demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate))) -> do + let ((weight, queue), rest) = assert (weight > 0) case egressQueues' of + [] -> error "impossible" + x:xs -> (x, xs) + egressQueues'' | weight > 1 = (pred weight, queue) : rest + | otherwise = rest + eSdu <- processSingleWanton sduSize mpc md d + case eSdu of + Right sdu | pbMaxBytes > 0 -> + -- we do not check if the protocol has any tokens to burst, + -- that is deferred to buildBatch below. + (sdu, egressQueues', True) <$ unGetTBQueue queue demand + | otherwise -> (sdu, egressQueues'', False) <$ writeTBQueue queue demand + Left sdu -> pure (sdu, egressQueues'', False) - sdus <- buildBatch [sdu] (sduLength sdu) mBurst start - void $ writeMany tracer timeout sdus - end <- getMonotonicTime - empty <- atomically $ isEmptyTBQueue egressQueue - when empty $ do - let delta = diffTime end start - threadDelay (egressInterval - delta) + (egressQueues'', batch'') <- + lift $ buildBatch (mkSingletonBatch sdu) egressQueues' burst start + put egressQueues'' + void . lift $ writeMany tracer timeout (getSdus batch'') + delta <- (`diffTime` start) <$> lift getMonotonicTime + lift . threadDelay $ egressInterval - delta where + numQueues :: Int + numQueues = length egressQueues0 + maxSDUsPerBatch :: Int maxSDUsPerBatch = 100 - sduLength :: SDU -> Int - sduLength sdu = fromIntegral msHeaderLength + fromIntegral (msLength sdu) + toDouble :: DiffTime -> Double + toDouble = realToFrac + + burstMinSdu = truncate @Double @SDUSize $ fromIntegral msHeaderLength / 0.02 -- Build a batch of SDUs to submit in one go to the bearer. -- Streams which are permitted to burst will have that many @@ -202,73 +245,92 @@ muxer egressQueue tracer Bearer { writeMany, sduSize, batchSize, egressInterval -- The batch size is either limited by the bearer -- (e.g the SO_SNDBUF for Socket) or number of SDUs. -- - buildBatch s sl mBurst0 start = reverse <$> go 1 s sl mBurst0 + buildBatch + :: SDUBatch -> [(Word8, EgressQueue m)] -> Bool -> Time -> m ([(Word8, EgressQueue m)], SDUBatch) + buildBatch batch0 egressQueues1 mBurst0 start = do + (qs, batch) <- go batch0 egressQueues1 mBurst0 + pure (qs, batch { getSdus = reverse (getSdus batch) }) where - toDouble :: DiffTime -> Double - toDouble = realToFrac + allM f = \case + [] -> pure True + (x:xs) -> do + res <- f x + if res then allM f xs else pure False + + go :: SDUBatch -> [(Word8, EgressQueue m)] -> Bool -> m ([(Word8, EgressQueue m)], SDUBatch) + go !_batch [] !_burst = error "impossible" + go batch egressQueues _burst + | getCount batch >= maxSDUsPerBatch || getSdusLength batch >= batchSize + = return (egressQueues, batch) + go batch egressQueues@((weight, queue):rest) mBurst = do + -- since the list of queues cycles, we only need to check the prefix + -- to see if there is any more work to do. + allEmpty0 <- atomically $ allM isEmptyTBQueue (snd <$> take numQueues egressQueues) + if allEmpty0 + then return (egressQueues, batch) + else do + mResult <- atomically $ tryReadTBQueue queue + case mResult of + Nothing -> go batch rest False + Just demand@(TLSRDemand mpc md d@Wanton { wLastSent, wBucket } (ProtocolBurst pbMaxBytes pbRefillRate)) -> do + (batch', goAgain) <- atomically do + delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) + thisEmpty <- isEmptyTBQueue queue + allEmpty <- (thisEmpty &&) <$> allM isEmptyTBQueue (snd <$> take (pred numQueues) rest) + let boundedTokens = min sduSize . fromIntegral . min (fromIntegral $ maxBound @SDUSize) + + step (!batch', !eSize) mx = do + -- the first one is always free + -- For Left's, we don't count the wanton bytes against the burst allowance + -- to permit a full sdu in the first iteration + let (size, consumedTokens) = either (, const 0) (, id) eSize + x <- lift $ mx size + case x of + Left sdu -> do + lift $ modifyTVar wBucket \tokens -> + let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) + in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) + tokens' + throwE (mkSingletonBatch sdu <> batch', not thisEmpty) + Right sdu -> do + nextSdu <- lift $ stateTVar wBucket \tokens -> + let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) + in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) + (boundedTokens tokens', tokens') + let batch'' = mkSingletonBatch sdu <> batch' + if nextSdu <= burstMinSdu -- 8 bytes header / 2% burst efficiency + then do + -- there is more payload, but burst allowance has been exhausted + lift $ writeTBQueue queue demand + throwE (batch'', True) + else pure (batch'', Right nextSdu) + either pure ((<$ writeTBQueue queue demand) . second (const True)) + =<< runExceptT do + sduSize0 <- lift $ stateTVar wBucket \tokens -> + let tokens' = truncate $ + min (fromIntegral pbMaxBytes) + (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) + -- we leverage burst and deduct credits only where there is contention + -- between protocols + sduSize0 | mBurst && not allEmpty = Right $ boundedTokens tokens' + | otherwise = Left sduSize + in (sduSize0, tokens') + when (fromRight maxBound sduSize0 <= burstMinSdu) do + -- edge case where the protocol is bursty, but there aren't enough tokens + -- available. The muxer forever loop does not check this + -- when it calls to build a batch, so we handle it here. + lift $ writeTBQueue queue demand + throwE (batch, True) + foldM step (batch, sduSize0) + (if allEmpty + then [const $ processSingleWanton sduSize mpc md d] + -- ^ grab full sdu, save the tokens for cases with contention + else repeat (\sduSize' -> processSingleWanton sduSize' mpc md d)) - go !count sdus _ _ | count >= maxSDUsPerBatch = return sdus - go _ sdus sdusLength _ | sdusLength >= batchSize = return sdus - go count sdus !sdusLength mBurst = do - mResult <- atomically $ tryReadTBQueue egressQueue - case mResult of - Nothing -> return sdus - Just demand@(TLSRDemand mpc md d@Wanton { wLastSent, wBucket } (ProtocolBurst pbMaxBytes pbRefillRate)) -> do - (count', sdusLength', sdus') <- atomically do - delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) - isEmpty <- isEmptyTBQueue egressQueue - let boundedTokens = min sduSize . fromIntegral . min (fromIntegral $ maxBound @SDUSize) - sduSize0 <- stateTVar wBucket \tokens -> - let tokens' = truncate $ - min (fromIntegral pbMaxBytes) - (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) - -- we leverage burst and deduct credits only where there is contention - -- between protocols - sduSize0 = bool (Left sduSize) (Right $ boundedTokens tokens') (mBurst && not isEmpty) - in (sduSize0, tokens') - let step (!count', !sdusLength', !sdus', !eSize) mx = do - -- the first one is always free - -- For Left's, we don't count the wanton bytes against the burst allowance - -- to permit a full sdu in the first iteration - let (size, consumedTokens) = either (, const 0) (, id) eSize - x <- lift $ mx size - case x of - Left sdu -> do - lift $ modifyTVar wBucket \tokens -> - let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) - in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) - tokens' - let sdusLength'' = sdusLength' + sduLength sdu - throwE (succ count', sdusLength'', sdu:sdus') - Right sdu -> do - nextSdu <- lift $ stateTVar wBucket \tokens -> - let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) - in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) - (boundedTokens tokens', tokens') - let sdusLength'' = sdusLength' + sduLength sdu - count'' = succ count' - if | nextSdu <= 400 -> do -- 8 bytes header / 2% burst efficiency - -- there is more payload, but burst allowance has been exhausted - lift $ writeTBQueue egressQueue demand - throwE (count'', sdusLength'', sdu:sdus') - | sdusLength'' >= batchSize || count'' >= maxSDUsPerBatch -> do - lift $ unGetTBQueue egressQueue demand - throwE (count'', sdusLength'', sdu:sdus') - | otherwise -> pure (count'', sdusLength'', sdu:sdus', Right nextSdu) - either pure (\(a, b, c, _d) -> (a, b, c) <$ writeTBQueue egressQueue demand) - =<< runExceptT do - when (either id id sduSize0 <= 400) do - -- edge case where the protocol is bursty, but there aren't enough tokens - -- available. The muxer forever loop does not check this - -- when it calls to build a batch, so we handle it here. - lift $ writeTBQueue egressQueue demand - throwE (count, sdusLength, sdus) - foldM step (count, sdusLength, sdus, sduSize0) - (if isEmpty - then [const $ processSingleWanton sduSize mpc md d] - -- ^ grab full sdu, save the tokens for cases with contention - else repeat (\sduSize' -> processSingleWanton sduSize' mpc md d)) - go count' sdus' sdusLength' False + if weight > 1 && goAgain + then let egressQueues' = (pred weight, queue) : rest + in go batch' egressQueues' False + else go batch' rest False -- | Pull a `maxSDU`s worth of data out out the `Wanton` - if there is diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs index db863da810e..61b60de28c8 100644 --- a/network-mux/src/Network/Mux/Types.hs +++ b/network-mux/src/Network/Mux/Types.hs @@ -157,8 +157,12 @@ data MiniProtocolInfo (mode :: Mode) = -- ^ Mini-protocol direction. miniProtocolLimits :: !MiniProtocolLimits, -- ^ ingress queue limits for the protocol - miniProtocolCapability :: !(Maybe Int) + miniProtocolCapability :: !(Maybe Int), -- ^ capability on which the mini-protocol should run + miniProtocolWeight :: !Word8 + -- ^ Protocols with the same weight will share + -- an egress queue of that value which biases + -- the muxer relative to other protocols } deriving Show diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs index 0904451bc23..420203c6fb8 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Mux.hs @@ -67,6 +67,7 @@ import Data.Foldable (fold) import Data.Hashable import Data.Kind (Type) import Data.Void (Void) +import Data.Word (Word8) import Network.TypedProtocol.Codec import Network.TypedProtocol.Core @@ -247,8 +248,9 @@ data MiniProtocol (mode :: Mux.Mode) initiatorCtx responderCtx bytes m a b = -- started using `StartEagerly`. miniProtocolLimits :: !MiniProtocolLimits, -- ^ mini-protocol limits - miniProtocolRun :: !(RunMiniProtocol mode initiatorCtx responderCtx bytes m a b) + miniProtocolRun :: !(RunMiniProtocol mode initiatorCtx responderCtx bytes m a b), -- ^ mini-protocol callback(s) + miniProtocolWeight :: !Word8 } mkMiniProtocolInfo :: ForkPolicyCb @@ -257,13 +259,15 @@ mkMiniProtocolInfo :: ForkPolicyCb mkMiniProtocolInfo forkPolicy MiniProtocol { miniProtocolNum, miniProtocolLimits, - miniProtocolRun + miniProtocolRun, + miniProtocolWeight } = [ Mux.MiniProtocolInfo { Mux.miniProtocolNum, Mux.miniProtocolDir = dir, Mux.miniProtocolLimits, + Mux.miniProtocolWeight, Mux.miniProtocolCapability = forkPolicy miniProtocolNum (Mux.protocolDirEnum dir) @@ -528,4 +532,3 @@ mkMiniProtocolInfos :: ForkPolicyCb -> OuroborosBundle mode initiatorCtx responderCtx bytes m a b -> [MiniProtocolInfo mode] mkMiniProtocolInfos forkPolicy = foldMap (foldMap (mkMiniProtocolInfo forkPolicy)) - From 31a8ea783ffd2776e04442f004db50913a91f53c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Fri, 27 Mar 2026 16:14:11 +0100 Subject: [PATCH 03/16] integrate bursty mux --- cardano-diffusion/demo/chain-sync.hs | 3 ++- .../lib/Cardano/Network/NodeToClient.hs | 5 +++-- .../lib/Cardano/Network/NodeToNode.hs | 21 ++++++++++++------- .../Network/Diffusion/Testnet/Simulation.hs | 2 +- network-mux/bench/socket_read_write/Main.hs | 2 +- network-mux/demo/mux-leios-demo.hs | 6 ++++-- network-mux/src/Network/Mux.hs | 1 + network-mux/test/Test/Mux.hs | 8 ++++--- ouroboros-network/demo/connection-manager.hs | 6 +++--- ouroboros-network/demo/ping-pong.hs | 5 ++--- .../io-tests/Test/Ouroboros/Network/Socket.hs | 3 ++- .../Test/Simulation/Network/Snocket.hs | 4 ++-- .../Network/ConnectionManager/Experiments.hs | 4 ++-- .../tests/io/Test/Ouroboros/Network/Pipe.hs | 3 ++- .../tests/io/Test/Ouroboros/Network/Socket.hs | 3 ++- .../tests/lib/Test/Ouroboros/Network/Mux.hs | 3 ++- 16 files changed, 48 insertions(+), 31 deletions(-) diff --git a/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index 32efff35323..2106140484d 100644 --- a/cardano-diffusion/demo/chain-sync.hs +++ b/cardano-diffusion/demo/chain-sync.hs @@ -209,7 +209,8 @@ rmIfExists path = do maximumMiniProtocolLimits :: MiniProtocolLimits maximumMiniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = maxBound + maximumIngressQueue = maxBound, + burst = Nothing } diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs index a180c3ea8c0..e114bf736ff 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs @@ -174,10 +174,11 @@ maximumMiniProtocolLimits :: MiniProtocolLimits maximumMiniProtocolLimits = MiniProtocolLimits { #if !defined(wasm32_HOST_ARCH) - maximumIngressQueue = 0xffffffff + maximumIngressQueue = 0xffffffff, #else - maximumIngressQueue = 0x7fffffff + maximumIngressQueue = 0x7fffffff, #endif + burst = Nothing } diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs index 3427f01fe86..101cc992185 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs @@ -342,7 +342,8 @@ chainSyncProtocolLimits MiniProtocolParameters { chainSyncPipeliningHighMark } = -- TODO: 1400 comes from maxBlockHeaderSize in genesis, but should come -- from consensus rather than being hard coded. maximumIngressQueue = addSafetyMargin $ - fromIntegral chainSyncPipeliningHighMark * 1400 + fromIntegral chainSyncPipeliningHighMark * 1400, + burst = Nothing } blockFetchProtocolLimits MiniProtocolParameters { blockFetchPipeliningMax } = MiniProtocolLimits { @@ -364,7 +365,8 @@ blockFetchProtocolLimits MiniProtocolParameters { blockFetchPipeliningMax } = Mi -- relaxed limit here. -- maximumIngressQueue = addSafetyMargin $ - max (10 * 2_097_154 :: Int) (fromIntegral blockFetchPipeliningMax * 90_112) + max (10 * 2_097_154 :: Int) (fromIntegral blockFetchPipeliningMax * 90_112), + burst = Just $ Mx.ProtocolBurst 90_112 10_000 } txSubmissionProtocolLimits MiniProtocolParameters @@ -432,13 +434,15 @@ txSubmissionProtocolLimits MiniProtocolParameters -- 10% as a safety margin. -- maximumIngressQueue = addSafetyMargin $ - fromIntegral maxUnacknowledgedTxIds * (44 + fromIntegral @SizeInBytes @Int max_TX_SIZE) + fromIntegral maxUnacknowledgedTxIds * (44 + fromIntegral @SizeInBytes @Int max_TX_SIZE), + burst = Nothing } keepAliveProtocolLimits _ = MiniProtocolLimits { -- One small outstanding message. - maximumIngressQueue = addSafetyMargin 1280 + maximumIngressQueue = addSafetyMargin 1280, + burst = Nothing } peerSharingProtocolLimits _ = @@ -449,7 +453,8 @@ peerSharingProtocolLimits _ = -- window size of 4 and a TCP segment is 1440, which gives us 4 * 1440 = -- 5760 bytes to fit into a single RTT. So setting the maximum ingress -- queue to be a single RTT should be enough to cover for CBOR overhead. - maximumIngressQueue = 4 * 1440 + maximumIngressQueue = 4 * 1440, + burst = Nothing } perasCertDiffusionProtocolLimits MiniProtocolParameters { perasCertDiffusionMaxObjectsUnacknowledged } = @@ -460,7 +465,8 @@ perasCertDiffusionProtocolLimits MiniProtocolParameters { perasCertDiffusionMaxO -- even much smaller. -- See https://github.com/tweag/cardano-peras/issues/97 maximumIngressQueue = addSafetyMargin $ - fromIntegral perasCertDiffusionMaxObjectsUnacknowledged * 20_000 + fromIntegral perasCertDiffusionMaxObjectsUnacknowledged * 20_000, + burst = Nothing } perasVoteDiffusionProtocolLimits MiniProtocolParameters { perasVoteDiffusionMaxObjectsUnacknowledged } = @@ -469,7 +475,8 @@ perasVoteDiffusionProtocolLimits MiniProtocolParameters { perasVoteDiffusionMaxO -- We assume an upper bound of 1 kB per vote. -- See https://github.com/tweag/cardano-peras/issues/97 maximumIngressQueue = addSafetyMargin $ - fromIntegral perasVoteDiffusionMaxObjectsUnacknowledged * 1_000 + fromIntegral perasVoteDiffusionMaxObjectsUnacknowledged * 1_000, + burst = Nothing } chainSyncMiniProtocolNum :: MiniProtocolNum diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs index c3ff4b7b20a..260e8872325 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs @@ -1210,7 +1210,7 @@ diffusionSimulationM acceptVersion = acceptableVersion defaultMiniProtocolsLimit :: MiniProtocolLimits defaultMiniProtocolsLimit = - MiniProtocolLimits { maximumIngressQueue = 64000 } + MiniProtocolLimits { maximumIngressQueue = 64000, burst = Nothing } blockGeneratorArgs :: Node.BlockGeneratorArgs Block StdGen blockGeneratorArgs = diff --git a/network-mux/bench/socket_read_write/Main.hs b/network-mux/bench/socket_read_write/Main.hs index d2b5f2736a9..413bcde41e6 100644 --- a/network-mux/bench/socket_read_write/Main.hs +++ b/network-mux/bench/socket_read_write/Main.hs @@ -253,7 +253,7 @@ startServerEgresss pollInterval sndSizeV ad = forever $ do let wasEmpty = BL.null buf writeTVar w (BL.append buf msg) when wasEmpty $ - writeTBQueue eq (TLSRDemand mc md (Wanton w) $ ProtocolBurst 1) + writeTBQueue eq (TLSRDemand mc md (Wanton w undefined undefined) undefined) else retry setupServer :: Socket -> IO Socket.SockAddr diff --git a/network-mux/demo/mux-leios-demo.hs b/network-mux/demo/mux-leios-demo.hs index 528b4a01e9d..86dd8e40f30 100644 --- a/network-mux/demo/mux-leios-demo.hs +++ b/network-mux/demo/mux-leios-demo.hs @@ -126,13 +126,15 @@ protocols miniProtocolDir = miniProtocolNum = MiniProtocolNum 2, miniProtocolDir, miniProtocolLimits = defaultProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } , MiniProtocolInfo { miniProtocolNum = MiniProtocolNum 3, miniProtocolDir, miniProtocolLimits = defaultProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 2db12578e98..4c1b3f7d0f9 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -26,6 +26,7 @@ module Network.Mux , MiniProtocolNum (..) , MiniProtocolDirection (..) , MiniProtocolLimits (..) + , ProtocolBurst (..) -- * Running the Mux , run , stop diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index eb6932c187b..548fc31ccb8 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -2398,7 +2398,8 @@ prop_mux_trailing_bytes reminder (NonEmptyByteString received) = do miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] withAsync (Mx.run mux bearer) $ \_ -> do @@ -2495,8 +2496,9 @@ prop_mux_pure_exception = do [ MiniProtocolInfo { miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, - miniProtocolCapability = Nothing + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] withAsync (Mx.run mux bearer) $ \_ -> do diff --git a/ouroboros-network/demo/connection-manager.hs b/ouroboros-network/demo/connection-manager.hs index 1ad711fb72c..ff6748a7328 100644 --- a/ouroboros-network/demo/connection-manager.hs +++ b/ouroboros-network/demo/connection-manager.hs @@ -321,7 +321,7 @@ withBidirectionalConnectionManager snocket makeBearer socket in MiniProtocol { miniProtocolNum, miniProtocolStart = StartOnDemand, - miniProtocolLimits = Mux.MiniProtocolLimits maxBound, + miniProtocolLimits = Mux.MiniProtocolLimits maxBound Nothing, miniProtocolRun = reqRespInitiatorAndResponder miniProtocolNum @@ -333,7 +333,7 @@ withBidirectionalConnectionManager snocket makeBearer socket in MiniProtocol { miniProtocolNum, miniProtocolStart = StartOnDemand, - miniProtocolLimits = Mux.MiniProtocolLimits maxBound, + miniProtocolLimits = Mux.MiniProtocolLimits maxBound Nothing, miniProtocolRun = reqRespInitiatorAndResponder miniProtocolNum @@ -345,7 +345,7 @@ withBidirectionalConnectionManager snocket makeBearer socket in MiniProtocol { miniProtocolNum, miniProtocolStart = StartOnDemandAny, - miniProtocolLimits = Mux.MiniProtocolLimits maxBound, + miniProtocolLimits = Mux.MiniProtocolLimits maxBound Nothing, miniProtocolRun = reqRespInitiatorAndResponder (Mux.MiniProtocolNum 3) diff --git a/ouroboros-network/demo/ping-pong.hs b/ouroboros-network/demo/ping-pong.hs index a3626b26485..d5e0c498982 100644 --- a/ouroboros-network/demo/ping-pong.hs +++ b/ouroboros-network/demo/ping-pong.hs @@ -90,7 +90,8 @@ rmIfExists path = do maximumMiniProtocolLimits :: MiniProtocolLimits maximumMiniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = maxBound + maximumIngressQueue = maxBound, + burst = Nothing } tracer :: Show a => Tracer IO a @@ -300,5 +301,3 @@ serverPingPong2 = , codecPingPong , pingPongServerPeer pingPongServerStandard ) - - diff --git a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs index 0e7037b4dcc..41662cac2a1 100644 --- a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -118,7 +118,8 @@ testProtocols2 reqResp = miniProtocolNum = MiniProtocolNum 4, miniProtocolStart = StartOnDemand, miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit + maximumIngressQueue = defaultMiniProtocolLimit, + burst = Nothing }, miniProtocolRun = reqResp } diff --git a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs index 47e87c74b4c..f272314f502 100644 --- a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs @@ -277,7 +277,7 @@ clientServerSimulation payloads = [ MiniProtocolInfo { miniProtocolNum = reqRespProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolCapability = Nothing } ]) @@ -331,7 +331,7 @@ clientServerSimulation payloads = [ MiniProtocolInfo { miniProtocolNum = reqRespProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolCapability = Nothing } ] diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index 9ff757b416b..90822c41b16 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -352,7 +352,7 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket [MiniProtocol { miniProtocolNum, miniProtocolStart = StartOnDemand, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolRun = reqRespInitiator miniProtocolNum nextRequest }] @@ -580,7 +580,7 @@ withBidirectionalConnectionManager name timeouts [MiniProtocol { miniProtocolNum, miniProtocolStart = Mx.StartOnDemand, - miniProtocolLimits = Mx.MiniProtocolLimits maxBound, + miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolRun = reqRespInitiatorAndResponder miniProtocolNum accumulatorInit diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs index 99d33234757..a2d1a081893 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs @@ -95,7 +95,8 @@ demoProtocols chainSync = miniProtocolNum = MiniProtocolNum 2, miniProtocolStart = StartOnDemand, miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit + maximumIngressQueue = defaultMiniProtocolLimit, + burst = Nothing }, miniProtocolRun = chainSync } diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs index 788c1cf2ea1..d929d9711b4 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs @@ -175,7 +175,8 @@ testProtocols1 chainSync = miniProtocolNum = MiniProtocolNum 2, miniProtocolStart = StartOnDemandAny, miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = defaultMiniProtocolLimit + maximumIngressQueue = defaultMiniProtocolLimit, + burst = Nothing }, miniProtocolRun = chainSync } diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs index f39d3f550fc..98c619d01cb 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs @@ -75,7 +75,8 @@ testProtocols chainSync = miniProtocolNum = MiniProtocolNum 2, miniProtocolStart = StartOnDemand, miniProtocolLimits = MiniProtocolLimits { - maximumIngressQueue = 0xffff + maximumIngressQueue = 0xffff, + burst = Nothing }, miniProtocolRun = chainSync } From 5d7048cd740c98a1fffea5907dfd6803fa1d0ff3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 30 Mar 2026 13:11:55 +0200 Subject: [PATCH 04/16] Always burst when possible Always bursting when possible should fill kernel buffer asap to beat a looming GC pause --- network-mux/src/Network/Mux/Egress.hs | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index b619a824e67..f51b9972e1f 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -276,7 +276,6 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva (batch', goAgain) <- atomically do delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) thisEmpty <- isEmptyTBQueue queue - allEmpty <- (thisEmpty &&) <$> allM isEmptyTBQueue (snd <$> take (pred numQueues) rest) let boundedTokens = min sduSize . fromIntegral . min (fromIntegral $ maxBound @SDUSize) step (!batch', !eSize) mx = do @@ -304,7 +303,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva lift $ writeTBQueue queue demand throwE (batch'', True) else pure (batch'', Right nextSdu) - either pure ((<$ writeTBQueue queue demand) . second (const True)) + either pure (error "impossible") =<< runExceptT do sduSize0 <- lift $ stateTVar wBucket \tokens -> let tokens' = truncate $ @@ -312,7 +311,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) -- we leverage burst and deduct credits only where there is contention -- between protocols - sduSize0 | mBurst && not allEmpty = Right $ boundedTokens tokens' + sduSize0 | mBurst = Right $ boundedTokens tokens' | otherwise = Left sduSize in (sduSize0, tokens') when (fromRight maxBound sduSize0 <= burstMinSdu) do @@ -322,10 +321,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva lift $ writeTBQueue queue demand throwE (batch, True) foldM step (batch, sduSize0) - (if allEmpty - then [const $ processSingleWanton sduSize mpc md d] - -- ^ grab full sdu, save the tokens for cases with contention - else repeat (\sduSize' -> processSingleWanton sduSize' mpc md d)) + (repeat (\sduSize' -> processSingleWanton sduSize' mpc md d)) if weight > 1 && goAgain then let egressQueues' = (pred weight, queue) : rest From 57a1d7a337ddf7b224488bf48fbea059be49259d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Tue, 24 Mar 2026 15:10:02 +0100 Subject: [PATCH 05/16] WFQ mux integration --- cardano-diffusion/demo/chain-sync.hs | 9 +- .../lib/Cardano/Network/NodeToClient.hs | 14 +-- .../lib/Cardano/Network/NodeToNode.hs | 21 +++-- .../Diffusion/Testnet/MiniProtocols.hs | 24 +++-- .../Network/Diffusion/Testnet/Simulation.hs | 7 +- network-mux/bench/socket_read_write/Main.hs | 13 +-- network-mux/demo/mux-demo.hs | 6 +- network-mux/test/Test/Mux.hs | 87 +++++++++++-------- ouroboros-network/demo/connection-manager.hs | 11 ++- ouroboros-network/demo/ping-pong.hs | 9 +- .../io-tests/Test/Ouroboros/Network/Socket.hs | 3 +- .../Ouroboros/Network/ConnectionHandler.hs | 6 +- .../lib/Ouroboros/Network/Server/Simple.hs | 6 +- .../framework/lib/Ouroboros/Network/Socket.hs | 18 ++-- .../Test/Ouroboros/Network/Server/Sim.hs | 5 +- .../Test/Simulation/Network/Snocket.hs | 14 +-- .../Network/ConnectionManager/Experiments.hs | 14 +-- .../lib/Ouroboros/Network/Diffusion.hs | 6 +- .../tests/io/Test/Ouroboros/Network/Pipe.hs | 3 +- .../tests/io/Test/Ouroboros/Network/Socket.hs | 3 +- .../Test/Ouroboros/Network/Diffusion/Node.hs | 8 +- .../tests/lib/Test/Ouroboros/Network/Mux.hs | 10 +-- 22 files changed, 177 insertions(+), 120 deletions(-) diff --git a/cardano-diffusion/demo/chain-sync.hs b/cardano-diffusion/demo/chain-sync.hs index 2106140484d..2d53c0344c6 100644 --- a/cardano-diffusion/demo/chain-sync.hs +++ b/cardano-diffusion/demo/chain-sync.hs @@ -227,7 +227,8 @@ demoProtocol2 chainSync = miniProtocolNum = MiniProtocolNum 2, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = chainSync + miniProtocolRun = chainSync, + miniProtocolWeight = 1 } ] @@ -337,13 +338,15 @@ demoProtocol3 chainSync blockFetch = miniProtocolNum = MiniProtocolNum 2, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = chainSync + miniProtocolRun = chainSync, + miniProtocolWeight = 1 } , MiniProtocol { miniProtocolNum = MiniProtocolNum 3, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = blockFetch + miniProtocolRun = blockFetch, + miniProtocolWeight = 1 } ] diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs index e114bf736ff..56e51d5a0d9 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToClient.hs @@ -52,8 +52,8 @@ module Cardano.Network.NodeToClient , Handshake ) where -import Control.Exception (SomeException) import Control.DeepSeq (NFData) +import Control.Exception (SomeException) import Control.Monad (forever) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadTimer.SI @@ -149,25 +149,29 @@ nodeToClientProtocols protocols _version _versionData = miniProtocolNum = MiniProtocolNum 5, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = localChainSyncProtocol + miniProtocolRun = localChainSyncProtocol, + miniProtocolWeight = 1 } localTxSubmissionMiniProtocol localTxSubmissionProtocol = MiniProtocol { miniProtocolNum = MiniProtocolNum 6, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = localTxSubmissionProtocol + miniProtocolRun = localTxSubmissionProtocol, + miniProtocolWeight = 1 } localStateQueryMiniProtocol localStateQueryProtocol = MiniProtocol { miniProtocolNum = MiniProtocolNum 7, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = localStateQueryProtocol + miniProtocolRun = localStateQueryProtocol, + miniProtocolWeight = 1 } localTxMonitorMiniProtocol localTxMonitorProtocol = MiniProtocol { miniProtocolNum = MiniProtocolNum 9, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = localTxMonitorProtocol + miniProtocolRun = localTxMonitorProtocol, + miniProtocolWeight = 1 } maximumMiniProtocolLimits :: MiniProtocolLimits diff --git a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs index 101cc992185..40fd18eaee6 100644 --- a/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs +++ b/cardano-diffusion/lib/Cardano/Network/NodeToNode.hs @@ -263,19 +263,22 @@ nodeToNodeProtocols _featureFlags miniProtocolParameters protocols miniProtocolNum = chainSyncMiniProtocolNum, miniProtocolStart = StartOnDemand, miniProtocolLimits = chainSyncProtocolLimits miniProtocolParameters, - miniProtocolRun = chainSyncProtocol + miniProtocolRun = chainSyncProtocol, + miniProtocolWeight = 1 } , MiniProtocol { miniProtocolNum = blockFetchMiniProtocolNum, miniProtocolStart = StartOnDemand, miniProtocolLimits = blockFetchProtocolLimits miniProtocolParameters, - miniProtocolRun = blockFetchProtocol + miniProtocolRun = blockFetchProtocol, + miniProtocolWeight = 1 } , MiniProtocol { miniProtocolNum = txSubmissionMiniProtocolNum, miniProtocolStart = StartOnDemand, miniProtocolLimits = txSubmissionProtocolLimits miniProtocolParameters, - miniProtocolRun = txSubmissionProtocol + miniProtocolRun = txSubmissionProtocol, + miniProtocolWeight = 1 } ] <> case perasSupport of @@ -287,13 +290,15 @@ nodeToNodeProtocols _featureFlags miniProtocolParameters protocols miniProtocolNum = perasCertDiffusionMiniProtocolNum, miniProtocolStart = StartOnDemand, miniProtocolLimits = perasCertDiffusionProtocolLimits miniProtocolParameters, - miniProtocolRun = perasCertDiffusionProtocol + miniProtocolRun = perasCertDiffusionProtocol, + miniProtocolWeight = 1 } , MiniProtocol { miniProtocolNum = perasVoteDiffusionMiniProtocolNum, miniProtocolStart = StartOnDemand, miniProtocolLimits = perasVoteDiffusionProtocolLimits miniProtocolParameters, - miniProtocolRun = perasVoteDiffusionProtocol + miniProtocolRun = perasVoteDiffusionProtocol, + miniProtocolWeight = 1 } ]) @@ -309,7 +314,8 @@ nodeToNodeProtocols _featureFlags miniProtocolParameters protocols miniProtocolNum = keepAliveMiniProtocolNum, miniProtocolStart = StartOnDemandAny, miniProtocolLimits = keepAliveProtocolLimits miniProtocolParameters, - miniProtocolRun = keepAliveProtocol + miniProtocolRun = keepAliveProtocol, + miniProtocolWeight = 1 } : case peerSharing of PeerSharingEnabled -> @@ -317,7 +323,8 @@ nodeToNodeProtocols _featureFlags miniProtocolParameters protocols miniProtocolNum = peerSharingMiniProtocolNum, miniProtocolStart = StartOnDemand, miniProtocolLimits = peerSharingProtocolLimits miniProtocolParameters, - miniProtocolRun = peerSharingProtocol + miniProtocolRun = peerSharingProtocol, + miniProtocolWeight = 1 } ] PeerSharingDisabled -> diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs index 9236cf4cf68..48969ca5a95 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs @@ -340,14 +340,16 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node -> MiniProtocolWithExpandedCtx Mx.InitiatorMode NtNAddr PeerTrustable ByteString m () Void f MiniProtocol { miniProtocolNum , miniProtocolLimits - , miniProtocolRun } = + , miniProtocolRun + , miniProtocolWeight } = MiniProtocol { miniProtocolNum , miniProtocolStart = StartEagerly , miniProtocolLimits , miniProtocolRun = case miniProtocolRun of InitiatorAndResponderProtocol initiator _respnder -> - InitiatorProtocolOnly initiator + InitiatorProtocolOnly initiator, + miniProtocolWeight } initiatorAndResponderApp @@ -362,7 +364,8 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node , miniProtocolRun = InitiatorAndResponderProtocol chainSyncInitiator - chainSyncResponder + chainSyncResponder, + miniProtocolWeight = 1 } , MiniProtocol { miniProtocolNum = blockFetchMiniProtocolNum @@ -371,7 +374,8 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node , miniProtocolRun = InitiatorAndResponderProtocol blockFetchInitiator - blockFetchResponder + blockFetchResponder, + miniProtocolWeight = 1 } , MiniProtocol { @@ -384,7 +388,8 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node (txSubmissionResponder (nkMempool nodeKernel) (nkTxChannelsVar nodeKernel) (nkTxMempoolSem nodeKernel) - (nkSharedTxStateVar nodeKernel)) + (nkSharedTxStateVar nodeKernel)), + miniProtocolWeight = 1 } ] , withWarm = WithWarm @@ -395,7 +400,8 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node , miniProtocolRun = InitiatorAndResponderProtocol pingPongInitiator - pingPongResponder + pingPongResponder, + miniProtocolWeight = 1 } ] , withEstablished = WithEstablished $ @@ -406,7 +412,8 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node , miniProtocolRun = InitiatorAndResponderProtocol keepAliveInitiator - keepAliveResponder + keepAliveResponder, + miniProtocolWeight = 1 } : case peerSharing of PSTypes.PeerSharingEnabled -> @@ -417,7 +424,8 @@ applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug node , miniProtocolRun = InitiatorAndResponderProtocol peerSharingInitiator - (peerSharingResponder (nkPeerSharingAPI nodeKernel)) + (peerSharingResponder (nkPeerSharingAPI nodeKernel)), + miniProtocolWeight = 1 } ] PSTypes.PeerSharingDisabled -> diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs index 260e8872325..de8f3abe313 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs @@ -38,11 +38,10 @@ module Test.Cardano.Network.Diffusion.Testnet.Simulation , module PeerSelection ) where -import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadMVar (MonadMVar) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (forM, when) +import Control.Monad (MonadPlus, forM, when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -1033,8 +1032,7 @@ data Churn = CardanoChurn | OuroborosChurn -- | Run an arbitrary topology in a generic monad `m`. -- diffusionSimulationM - :: forall m. ( Alternative (STM m) - , MonadAsync m + :: forall m. ( MonadAsync m , MonadDelay m , MonadFix m , MonadEvaluate m @@ -1045,6 +1043,7 @@ diffusionSimulationM , MonadLabelledSTM m , MonadTraceSTM m , MonadMask m + , MonadPlus (STM m) , MonadTime m , MonadTimer m , MonadThrow (STM m) diff --git a/network-mux/bench/socket_read_write/Main.hs b/network-mux/bench/socket_read_write/Main.hs index 413bcde41e6..4916e02d07f 100644 --- a/network-mux/bench/socket_read_write/Main.hs +++ b/network-mux/bench/socket_read_write/Main.hs @@ -144,7 +144,7 @@ mkMiniProtocolState num = do mpv <- newTVarIO StatusRunning let mpi = MiniProtocolInfo (MiniProtocolNum num) InitiatorDirectionOnly - (MiniProtocolLimits maxBound Nothing) Nothing + (MiniProtocolLimits maxBound Nothing) Nothing 1 return $ MiniProtocolState mpi mpq mpv -- | Run a server that accept connections on `ad`. @@ -208,7 +208,8 @@ startServerEgresss pollInterval sndSizeV ad = forever $ do withReadBufferIO (\buffer -> do bearer <- getBearer (makeSocketBearer' pollInterval) sduTimeout sd buffer sndSize <- atomically $ takeTMVar sndSizeV - eq <- atomically $ newTBQueue 100 + eq' <- atomically $ newTBQueue 100 + let eq = [(1, eq')] w42 <- newTVarIO BL.empty w41 <- newTVarIO BL.empty @@ -222,13 +223,13 @@ startServerEgresss pollInterval sndSizeV ad = forever $ do replicateM_ numberOfCalls $ do let payload42s = replicate 10 $ BL.replicate sndSize 42 let payload41s = replicate 10 $ BL.replicate 10 41 - mapM_ (sendToMux w42 eq (MiniProtocolNum 42) ResponderDir) payload42s - mapM_ (sendToMux w41 eq (MiniProtocolNum 41) ResponderDir) payload41s + mapM_ (sendToMux w42 eq' (MiniProtocolNum 42) ResponderDir) payload42s + mapM_ (sendToMux w41 eq' (MiniProtocolNum 41) ResponderDir) payload41s when (runtSdus > 0) $ do let payload42s = replicate runtSdus $ BL.replicate sndSize 42 let payload41s = replicate runtSdus $ BL.replicate 10 41 - mapM_ (sendToMux w42 eq (MiniProtocolNum 42) ResponderDir) payload42s - mapM_ (sendToMux w41 eq (MiniProtocolNum 41) ResponderDir) payload41s + mapM_ (sendToMux w42 eq' (MiniProtocolNum 42) ResponderDir) payload42s + mapM_ (sendToMux w41 eq' (MiniProtocolNum 41) ResponderDir) payload41s -- Wait for the egress queue to empty atomically $ do diff --git a/network-mux/demo/mux-demo.hs b/network-mux/demo/mux-demo.hs index 6acb8a43c95..b4795c17d8d 100644 --- a/network-mux/demo/mux-demo.hs +++ b/network-mux/demo/mux-demo.hs @@ -147,7 +147,8 @@ serverWorker bearer = do miniProtocolNum = MiniProtocolNum 2, miniProtocolDir = ResponderDirectionOnly, miniProtocolLimits = defaultProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] @@ -207,7 +208,8 @@ clientWorker bearer n msg = do miniProtocolNum = MiniProtocolNum 2, miniProtocolDir = InitiatorDirectionOnly, miniProtocolLimits = defaultProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index 548fc31ccb8..c5eae01d5c8 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -374,14 +374,16 @@ prop_mux_snd_recv (DummyRun messages) = ioProperty $ do miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.InitiatorDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } serverApp = MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } clientMux <- Mx.new clientTracer [clientApp] @@ -447,13 +449,15 @@ prop_mux_snd_recv_bi (DummyRun messages) (DummyCapability clientCap) (DummyCapab miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.InitiatorDirection, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } , MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.ResponderDirection, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = clientCap + miniProtocolCapability = clientCap, + miniProtocolWeight = 1 } ] @@ -462,13 +466,15 @@ prop_mux_snd_recv_bi (DummyRun messages) (DummyCapability clientCap) (DummyCapab miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.ResponderDirection, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = serverCap + miniProtocolCapability = serverCap, + miniProtocolWeight = 1 } , MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.InitiatorDirection, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] @@ -562,14 +568,16 @@ prop_mux_snd_recv_compat messages = ioProperty $ do miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolLimits = defaultMiniProtocolLimits, miniProtocolDir = Mx.InitiatorDirectionOnly, - miniProtocolCapability = Nothing } + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] serverBundle = [ MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolLimits = defaultMiniProtocolLimits, miniProtocolDir = Mx.ResponderDirectionOnly, - miniProtocolCapability = Nothing } + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] clientAsync <- async $ do @@ -768,7 +776,8 @@ runMuxApplication (DummyCapability rspCap) initApps initBearer respApps respBear miniProtocolNum = Mx.MiniProtocolNum pn, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = rspCap + miniProtocolCapability = rspCap, + miniProtocolWeight = 1 } ) respApps' @@ -787,7 +796,8 @@ runMuxApplication (DummyCapability rspCap) initApps initBearer respApps respBear miniProtocolNum = Mx.MiniProtocolNum pn, miniProtocolDir = Mx.InitiatorDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ) initApps' @@ -1045,13 +1055,15 @@ prop_mux_starvation (Uneven response0 response1) = miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.InitiatorDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } clientApp3 = MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 3, miniProtocolDir = Mx.InitiatorDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } serverApp2, serverApp3 :: MiniProtocolInfo Mx.ResponderMode @@ -1059,13 +1071,15 @@ prop_mux_starvation (Uneven response0 response1) = miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } serverApp3 = MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 3, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } serverMux <- Mx.new serverTracer [serverApp2, serverApp3] @@ -1153,8 +1167,7 @@ encodeInvalidMuxSDU sdu = -- | Verify ingress processing of valid and invalid SDUs. -- prop_demux_sdu :: forall m. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m @@ -1163,6 +1176,7 @@ prop_demux_sdu :: forall m. , MonadSay m , MonadThrow (STM m) , MonadTimer m + , MonadPlus (STM m) ) => ArbitrarySDU -> m Property @@ -1181,7 +1195,8 @@ prop_demux_sdu a = do miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = smallMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } (client_w, said, waitServerRes, mux) <- plainServer server_mps (serverRsp stopVar) @@ -1210,7 +1225,8 @@ prop_demux_sdu a = do miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } (client_w, said, waitServerRes, mux) <- plainServer server_mps (serverRsp stopVar) @@ -1238,7 +1254,8 @@ prop_demux_sdu a = do miniProtocolNum = Mx.MiniProtocolNum 2, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } (client_w, said, waitServerRes, mux) <- plainServer server_mps (serverRsp stopVar) @@ -1474,7 +1491,7 @@ dummyRestartingAppToChannel (app, r) = \_ -> do appToInfo :: Mx.MiniProtocolDirection mode -> DummyApp -> MiniProtocolInfo mode -appToInfo d da = MiniProtocolInfo (daNum da) d defaultMiniProtocolLimits Nothing +appToInfo d da = MiniProtocolInfo (daNum da) d defaultMiniProtocolLimits Nothing 1 triggerApp :: forall m. ( MonadAsync m @@ -1493,8 +1510,7 @@ triggerApp bearer app = do return () prop_mux_start_mX :: forall m. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m @@ -1503,6 +1519,7 @@ prop_mux_start_mX :: forall m. , MonadSay m , MonadThrow (STM m) , MonadTimer m + , MonadPlus (STM m) ) => DummyApps -> DiffTime @@ -1557,8 +1574,7 @@ prop_mux_start_mX apps runTime = do Right _ -> return (counterexample "not-failed" False, r) prop_mux_restart_m :: forall m. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m @@ -1567,6 +1583,7 @@ prop_mux_restart_m :: forall m. , MonadSay m , MonadThrow (STM m) , MonadTimer m + , MonadPlus (STM m) ) => DummyRestartingApps -> m Property @@ -1728,8 +1745,7 @@ prop_mux_restart_m (DummyRestartingInitiatorResponderApps rapps) = do -- | Verifying starting and stopping of miniprotocols. Both normal exits and by exception. prop_mux_start_m :: forall m. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m @@ -1738,6 +1754,7 @@ prop_mux_start_m :: forall m. , MonadSay m , MonadThrow (STM m) , MonadTimer m + , MonadPlus (STM m) ) => Mx.Bearer m -- ^ Mux bearer @@ -1975,8 +1992,7 @@ withNetworkCtx NetworkCtx { ncSocket, ncClose, ncMuxBearer } k = close_experiment :: forall sock acc req resp m. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m @@ -1985,6 +2001,7 @@ close_experiment , MonadTimer m , MonadThrow (STM m) , MonadST m + , MonadPlus (STM m) , Serialise req , Serialise resp , Eq resp @@ -2019,7 +2036,8 @@ close_experiment miniProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ]) Mx.stop $ \mux -> @@ -2039,7 +2057,8 @@ close_experiment miniProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ]) Mx.stop $ \mux -> @@ -2373,13 +2392,13 @@ instance Arbitrary NonEmptyByteString where ] prop_mux_trailing_bytes - :: ( Alternative (STM m) - , MonadAsync m + :: ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m , MonadLabelledSTM m , MonadMask m + , MonadPlus (STM m) , MonadTimer m , MonadThrow (STM m) ) @@ -2474,13 +2493,13 @@ prop_mux_trailing_bytes_io reminder received = prop_mux_pure_exception - :: ( Alternative (STM m) - , MonadAsync m + :: ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m , MonadLabelledSTM m , MonadMask m + , MonadPlus (STM m) , MonadTimer m , MonadThrow (STM m) ) diff --git a/ouroboros-network/demo/connection-manager.hs b/ouroboros-network/demo/connection-manager.hs index ff6748a7328..aed0600e092 100644 --- a/ouroboros-network/demo/connection-manager.hs +++ b/ouroboros-network/demo/connection-manager.hs @@ -25,6 +25,7 @@ module Main (main) where import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (IOException) +import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -190,6 +191,7 @@ withBidirectionalConnectionManager , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m + , MonadPlus (STM m) ) => Snocket m socket peerAddr -> Mux.MakeBearer m socket @@ -325,7 +327,8 @@ withBidirectionalConnectionManager snocket makeBearer socket miniProtocolRun = reqRespInitiatorAndResponder miniProtocolNum - hotRequestsVar + hotRequestsVar, + miniProtocolWeight = 1 } ], withWarm = WithWarm @@ -337,7 +340,8 @@ withBidirectionalConnectionManager snocket makeBearer socket miniProtocolRun = reqRespInitiatorAndResponder miniProtocolNum - warmRequestsVar + warmRequestsVar, + miniProtocolWeight = 1 } ], withEstablished = WithEstablished @@ -349,7 +353,8 @@ withBidirectionalConnectionManager snocket makeBearer socket miniProtocolRun = reqRespInitiatorAndResponder (Mux.MiniProtocolNum 3) - establishedRequestsVar + establishedRequestsVar, + miniProtocolWeight = 1 } ] } diff --git a/ouroboros-network/demo/ping-pong.hs b/ouroboros-network/demo/ping-pong.hs index d5e0c498982..0a1ff3e508b 100644 --- a/ouroboros-network/demo/ping-pong.hs +++ b/ouroboros-network/demo/ping-pong.hs @@ -113,7 +113,8 @@ demoProtocol0 pingPong = miniProtocolNum = MiniProtocolNum 2, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = pingPong + miniProtocolRun = pingPong, + miniProtocolWeight = 1 } ] @@ -205,13 +206,15 @@ demoProtocol1 pingPong pingPong' = miniProtocolNum = MiniProtocolNum 2, miniProtocolStart = StartOnDemand, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = pingPong + miniProtocolRun = pingPong, + miniProtocolWeight = 1 } , MiniProtocol { miniProtocolNum = MiniProtocolNum 3, miniProtocolStart = StartOnDemandAny, miniProtocolLimits = maximumMiniProtocolLimits, - miniProtocolRun = pingPong' + miniProtocolRun = pingPong', + miniProtocolWeight = 1 } ] diff --git a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs index 41662cac2a1..99be869a07f 100644 --- a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -121,7 +121,8 @@ testProtocols2 reqResp = maximumIngressQueue = defaultMiniProtocolLimit, burst = Nothing }, - miniProtocolRun = reqResp + miniProtocolRun = reqResp, + miniProtocolWeight = 1 } ] diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs index b4b93544114..cafbf4b5eb6 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionHandler.hs @@ -42,10 +42,10 @@ module Ouroboros.Network.ConnectionHandler , ConnectionHandlerTrace (..) ) where -import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData) import Control.Exception (SomeAsyncException) +import Control.Monad (MonadPlus) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow hiding (handle) @@ -242,8 +242,7 @@ type ConnectionManagerWithExpandedCtx muxMode socket peerAddr extraFlags version -- makeConnectionHandler :: forall initiatorCtx responderCtx peerAddr muxMode socket versionNumber versionData m a b. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m @@ -251,6 +250,7 @@ makeConnectionHandler , MonadThrow (STM m) , MonadTimer m , MonadMask m + , MonadPlus (STM m) , NFData versionData , NFData versionNumber , Ord versionNumber diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs index 44e426e4233..befbadcebcf 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Server/Simple.hs @@ -14,9 +14,9 @@ module Ouroboros.Network.Server.Simple , ServerTracer (..) ) where -import Control.Applicative (Alternative) import Control.Concurrent.JobPool qualified as JobPool import Control.DeepSeq (NFData) +import Control.Monad (MonadPlus) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow @@ -43,13 +43,13 @@ data ServerTracer addr deriving Show with :: forall fd addr vNumber vData m a b. - ( Alternative (STM m), - MonadAsync m, + ( MonadAsync m, MonadDelay m, MonadEvaluate m, MonadFork m, MonadLabelledSTM m, MonadMask m, + MonadPlus (STM m), MonadTimer m, MonadThrow (STM m), NFData vData, diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs index 989a180596e..a8f1d892926 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Socket.hs @@ -63,7 +63,7 @@ import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData) #if !defined(wasm32_HOST_ARCH) -import Control.Monad (unless, when) +import Control.Monad (MonadPlus, unless, when) #endif import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork @@ -264,13 +264,13 @@ data ConnectToArgs m fd addr vNumber vData = ConnectToArgs { -- Exceptions thrown by 'MuxApplication' are rethrown by 'connectToNode'. connectToNode :: forall muxMode vNumber vData fd addr m a b. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m , MonadLabelledSTM m , MonadMask m + , MonadPlus (STM m) , Mx.MonadReadBuffer m , MonadSTM m , MonadTimer m @@ -303,13 +303,13 @@ connectToNode sn mkBearer args configureSock versions localAddr remoteAddr = -- to execute on a given connection. connectToNodeWithMux :: forall muxMode vNumber vData fd addr m a b x. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m , MonadLabelledSTM m , MonadMask m + , MonadPlus (STM m) , Mx.MonadReadBuffer m , MonadSTM m , MonadTimer m @@ -366,13 +366,13 @@ connectToNodeWithMux sn mkBearer args configureSock versions localAddr remoteAdd -- Exceptions thrown by @'MuxApplication'@ are rethrown by @'connectTo'@. connectToNode' :: forall muxMode vNumber vData fd addr m a b. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadFork m , MonadEvaluate m , MonadLabelledSTM m , MonadMask m + , MonadPlus (STM m) , Mx.MonadReadBuffer m , MonadSTM m , MonadTimer m @@ -401,13 +401,13 @@ connectToNode' sn mkBearer args versions as = connectToNodeWithMux' :: forall muxMode vNumber vData fd addr m a b x. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadFork m , MonadEvaluate m , MonadLabelledSTM m , MonadMask m + , MonadPlus (STM m) , Mx.MonadReadBuffer m , MonadSTM m , MonadTimer m diff --git a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index 47085e89ff4..11d7994776e 100644 --- a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -29,7 +29,7 @@ import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData) import Control.Exception (SomeAsyncException (..), SomeException (..)) -import Control.Monad (replicateM) +import Control.Monad (MonadPlus, replicateM) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -628,6 +628,7 @@ multinodeExperiment , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m + , MonadPlus (STM m) , acc ~ [req], resp ~ [req] , Ord peerAddr , PrettyShow peerAddr @@ -2300,7 +2301,7 @@ prop_server_accept_error (Fixed rnd) (AbsIOError ioerr) = -multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m +multiNodeSimTracer :: ( Monad m, MonadFix m, MonadPlus (STM m) , MonadDelay m, MonadTimer m, MonadLabelledSTM m , MonadTraceSTM m, MonadMask m, MonadTime m , MonadThrow (STM m), MonadSay m, MonadAsync m diff --git a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs index f272314f502..e0607b31673 100644 --- a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs @@ -18,8 +18,8 @@ module Test.Simulation.Network.Snocket , toBearerInfo ) where -import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -39,7 +39,6 @@ import Codec.Serialise qualified as Serialise import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as BL import Data.Foldable (traverse_) -import Data.Functor (void) import Data.Map qualified as Map import Data.Maybe (isNothing) import Data.Set (Set) @@ -186,8 +185,7 @@ untilSuccess go = clientServerSimulation :: forall m addr payload. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFork m @@ -197,7 +195,7 @@ clientServerSimulation , MonadST m , MonadThrow (STM m) , MonadTimer m - + , MonadPlus (STM m) , Serialise payload , Eq payload , Show payload @@ -278,7 +276,8 @@ clientServerSimulation payloads = miniProtocolNum = reqRespProtocolNum, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ]) Mx.stop @@ -332,7 +331,8 @@ clientServerSimulation payloads = miniProtocolNum = reqRespProtocolNum, miniProtocolDir = Mx.InitiatorDirectionOnly, miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, - miniProtocolCapability = Nothing + miniProtocolCapability = Nothing, + miniProtocolWeight = 1 } ] diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index 90822c41b16..4a325a20d4d 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -39,7 +39,7 @@ import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData) import Control.Exception (AssertionFailed) -import Control.Monad (replicateM, (>=>)) +import Control.Monad (MonadPlus, replicateM, (>=>)) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -252,6 +252,7 @@ withInitiatorOnlyConnectionManager , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m + , MonadPlus (STM m) , Show name ) => name @@ -354,7 +355,8 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket miniProtocolStart = StartOnDemand, miniProtocolLimits = Mx.MiniProtocolLimits maxBound Nothing, miniProtocolRun = reqRespInitiator miniProtocolNum - nextRequest + nextRequest, + miniProtocolWeight = 1 }] reqRespInitiator :: Mx.MiniProtocolNum @@ -437,6 +439,7 @@ withBidirectionalConnectionManager , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m, Show req + , MonadPlus (STM m) , NFData req , Show name ) @@ -584,7 +587,8 @@ withBidirectionalConnectionManager name timeouts miniProtocolRun = reqRespInitiatorAndResponder miniProtocolNum accumulatorInit - nextRequest + nextRequest, + miniProtocolWeight = 1 }] reqRespInitiatorAndResponder @@ -741,7 +745,7 @@ unidirectionalExperiment , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m - + , MonadPlus (STM m) , acc ~ [req], resp ~ [req] , Ord peerAddr , PrettyShow peerAddr @@ -822,7 +826,7 @@ bidirectionalExperiment , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m - + , MonadPlus (STM m) , acc ~ [req], resp ~ [req] , Ord peerAddr , PrettyShow peerAddr diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs index 7e87dcfbecf..1b40822be81 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs @@ -20,11 +20,11 @@ module Ouroboros.Network.Diffusion ) where -import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadMVar (MonadMVar) import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData) import Control.Exception (IOException) +import Control.Monad (MonadPlus) import Control.Monad.Class.MonadAsync (Async, MonadAsync) import Control.Monad.Class.MonadAsync qualified as Async import Control.Monad.Class.MonadFork @@ -97,8 +97,7 @@ runM extraState extraDebugState extraPeers extraAPI extraFlags extraChurnArgs. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFix m @@ -106,6 +105,7 @@ runM , MonadLabelledSTM m , MonadTraceSTM m , MonadMask m + , MonadPlus (STM m) , MonadThrow (STM m) , MonadTime m , MonadTimer m diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs index a2d1a081893..b09a8c18987 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Pipe.hs @@ -98,7 +98,8 @@ demoProtocols chainSync = maximumIngressQueue = defaultMiniProtocolLimit, burst = Nothing }, - miniProtocolRun = chainSync + miniProtocolRun = chainSync, + miniProtocolWeight = 1 } ] diff --git a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs index d929d9711b4..5d6df16bf8f 100644 --- a/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/tests/io/Test/Ouroboros/Network/Socket.hs @@ -178,7 +178,8 @@ testProtocols1 chainSync = maximumIngressQueue = defaultMiniProtocolLimit, burst = Nothing }, - miniProtocolRun = chainSync + miniProtocolRun = chainSync, + miniProtocolWeight = 1 } ] diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index 1d21078c834..b0b35dfb016 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -36,10 +36,9 @@ module Test.Ouroboros.Network.Diffusion.Node , Node.ntnAddrToRelayAccessPoint ) where -import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadMVar (MonadMVar) import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad ((>=>)) +import Control.Monad (MonadPlus, (>=>)) import Control.Monad.Class.MonadAsync (MonadAsync (wait, withAsync)) import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -178,8 +177,7 @@ data Arguments extraChurnArgs extraFlags m = Arguments run :: forall extraState extraDebugState extraAPI extraPeers extraFlags extraChurnArgs exception resolver m. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadEvaluate m , MonadFix m @@ -193,7 +191,7 @@ run :: forall extraState extraDebugState extraAPI , MonadTimer m , MonadThrow (STM m) , MonadMVar m - + , MonadPlus (STM m) , Eq extraFlags , Monoid extraPeers , SupportsPeerSelectionState extraPeers NtNAddr diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs index 98c619d01cb..873508c73dc 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Mux.hs @@ -10,11 +10,10 @@ module Test.Ouroboros.Network.Mux (tests) where import Codec.Serialise (Serialise (..)) -import Data.Functor (void) import Data.Monoid.Synchronisation (FirstToFinish (..)) -import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay @@ -78,14 +77,14 @@ testProtocols chainSync = maximumIngressQueue = 0xffff, burst = Nothing }, - miniProtocolRun = chainSync + miniProtocolRun = chainSync, + miniProtocolWeight = 1 } ] demo :: forall m block. - ( Alternative (STM m) - , MonadAsync m + ( MonadAsync m , MonadDelay m , MonadCatch m , MonadEvaluate m @@ -98,6 +97,7 @@ demo :: forall m block. , MonadThrow (STM m) , MonadTime m , MonadTimer m + , MonadPlus (STM m) , Chain.HasHeader block , Serialise (Chain.HeaderHash block) , Serialise block From 474a7fc2e511b68e5581f81001dd69da0fcc6436 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 30 Mar 2026 12:53:50 +0200 Subject: [PATCH 06/16] WFQ mux fairness test The test has been enhanced to cover biased queuing --- network-mux/test/Test/Mux.hs | 74 ++++++++++++++++++++++++++---------- 1 file changed, 54 insertions(+), 20 deletions(-) diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index c5eae01d5c8..118871fa413 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} @@ -29,7 +30,7 @@ import Data.Bits import Data.ByteString.Lazy qualified as BL import Data.ByteString.Lazy.Char8 qualified as BL8 (pack) import Data.Functor.Contravariant ((>$<)) -import Data.List (dropWhileEnd, nub) +import Data.List (dropWhileEnd, group, nub) import Data.List qualified as List import Data.Map qualified as M import Data.Maybe (isNothing) @@ -314,6 +315,35 @@ instance Arbitrary DummyCapability where ] +newtype MiniProtocolWeights = MiniProtocolWeights (MiniProtocolWeight, MiniProtocolWeight) + deriving (Eq, Show) + +instance Arbitrary MiniProtocolWeights where + arbitrary = do + wt1 <- arbitrary + wt2 <- arbitrary + let mkWt = MiniProtocolWeight + if wt1 == wt2 + then pure $ MiniProtocolWeights (mkWt 1, mkWt 1) + else pure $ MiniProtocolWeights (wt1, wt2) + + shrink (MiniProtocolWeights (wt1, wt2)) = + let mkWt = MiniProtocolWeight + in MiniProtocolWeights (mkWt 1, mkWt 1) + : [ MiniProtocolWeights (wt1', wt2') + | wt1' <- shrink wt1 + , wt2' <- shrink wt2 + ] + + +newtype MiniProtocolWeight = MiniProtocolWeight Word8 + deriving (Eq, Show) + +instance Arbitrary MiniProtocolWeight where + arbitrary = MiniProtocolWeight <$> choose (1, 4) + shrink (MiniProtocolWeight wt) = MiniProtocolWeight <$> filter (> 0) (shrink wt) + + -- | A pair of two bytestrings which lengths are unevenly distributed -- data Uneven = Uneven DummyPayload DummyPayload @@ -1008,8 +1038,10 @@ prop_mux_2_minis_Socket_buf cap a b = ioProperty $ -- The Mux bearer should alternate between sending data for the two responders. -- prop_mux_starvation :: Uneven + -> MiniProtocolWeights -> Property -prop_mux_starvation (Uneven response0 response1) = +prop_mux_starvation (Uneven response0 response1) + (MiniProtocolWeights (MiniProtocolWeight wt1, MiniProtocolWeight wt2)) = let sduLen = Mx.SDUSize 1280 in (BL.length (unDummyPayload response0) > 2 * fromIntegral (Mx.getSDUSize sduLen)) && (BL.length (unDummyPayload response1) > 2 * fromIntegral (Mx.getSDUSize sduLen)) ==> @@ -1072,14 +1104,14 @@ prop_mux_starvation (Uneven response0 response1) = miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, miniProtocolCapability = Nothing, - miniProtocolWeight = 1 + miniProtocolWeight = wt1 } serverApp3 = MiniProtocolInfo { miniProtocolNum = Mx.MiniProtocolNum 3, miniProtocolDir = Mx.ResponderDirectionOnly, miniProtocolLimits = defaultMiniProtocolLimits, miniProtocolCapability = Nothing, - miniProtocolWeight = 1 + miniProtocolWeight = wt2 } serverMux <- Mx.new serverTracer [serverApp2, serverApp3] @@ -1119,28 +1151,30 @@ prop_mux_starvation (Uneven response0 response1) = -- Then look at the message trace to check for starvation. trace <- atomically $ readTVar traceHeaderVar - let es = map Mx.mhNum (take 100 (reverse trace)) - ls = dropWhile (\e -> e == head es) es - fair = verifyStarvation ls + let es = map Mx.mhNum (take 100 (reverse trace)) + -- We can't make 100% sure that both servers start responding at the same + -- time but once they are both up and running messages should alternate + -- between ReqResp2 and ReqResp3, so we drop the prefix of the protocol + -- which goes first, and trim the suffix when the first protocol finishes + ls = dropWhile (\e -> e == head es) es + ls' = dropWhileEnd (\e -> e == last ls) ls + fair = counterexample "muxer didn't interleave" (not . null $ ls') + .&&. label ("shrinkage " ++ labelPr_ ((length ls' * 100) `div` length es) ++ "%") + (verifyStarvation ls' (\case (Mx.MiniProtocolNum 2) -> wt1; _otherwise -> wt2)) return $ res_short .&&. res_long .&&. fair where - -- We can't make 100% sure that both servers start responding at the same - -- time but once they are both up and running messages should alternate - -- between ReqResp2 and ReqResp3 - verifyStarvation :: Eq a => [a] -> Property - verifyStarvation [] = property True - verifyStarvation ms = - let ms' = dropWhileEnd (\e -> e == last ms) - (head ms : dropWhile (\e -> e == head ms) ms) - ++ [last ms] - in - label ("length " ++ labelPr_ ((length ms' * 100) `div` length ms) ++ "%") - $ label ("length " ++ label_ (length ms')) $ alternates ms' + verifyStarvation :: Eq a => [a] -> (a -> Word8) -> Property + verifyStarvation [] _atowt = property True + verifyStarvation ms atowt = label ("length " ++ label_ (length ms)) . + label ("groups " ++ label_ (length (group ms))) . + alternates $ group ms where alternates [] = True alternates (_:[]) = True - alternates (a : b : as) = a /= b && alternates (b : as) + alternates (a : b : []) = length a <= fromIntegral (atowt (head a)) + && length b <= fromIntegral (atowt (head b)) + alternates (a : b : as) = (length a == fromIntegral (atowt (head a))) && alternates (b : as) label_ :: Int -> String label_ n = mconcat From f20cd810316230075c8807e2eccca0d622fd1244 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Mon, 30 Mar 2026 13:43:53 +0200 Subject: [PATCH 07/16] changelog fragment --- ...ile-dentist_mux_single_peer_performance.md | 23 +++++++++++++ ...ile-dentist_mux_single_peer_performance.md | 32 +++++++++++++++++++ ...ile-dentist_mux_single_peer_performance.md | 23 +++++++++++++ 3 files changed, 78 insertions(+) create mode 100644 cardano-diffusion/changelog.d/20260330_134910_crocodile-dentist_mux_single_peer_performance.md create mode 100644 network-mux/changelog.d/20260330_133633_crocodile-dentist_mux_single_peer_performance.md create mode 100644 ouroboros-network/changelog.d/20260330_134651_crocodile-dentist_mux_single_peer_performance.md diff --git a/cardano-diffusion/changelog.d/20260330_134910_crocodile-dentist_mux_single_peer_performance.md b/cardano-diffusion/changelog.d/20260330_134910_crocodile-dentist_mux_single_peer_performance.md new file mode 100644 index 00000000000..8dc740b9aa4 --- /dev/null +++ b/cardano-diffusion/changelog.d/20260330_134910_crocodile-dentist_mux_single_peer_performance.md @@ -0,0 +1,23 @@ + + + +### Non-Breaking + +- Integrate weighted fair queue + burst mux + + diff --git a/network-mux/changelog.d/20260330_133633_crocodile-dentist_mux_single_peer_performance.md b/network-mux/changelog.d/20260330_133633_crocodile-dentist_mux_single_peer_performance.md new file mode 100644 index 00000000000..02d71ee5551 --- /dev/null +++ b/network-mux/changelog.d/20260330_133633_crocodile-dentist_mux_single_peer_performance.md @@ -0,0 +1,32 @@ + + +### Breaking + +- Added support for burst and weighted fair queuing: + - Added `wLastSent` and `wBucket` to Wanton + - Introduced `ProtocolBurst` type, holding token bucket size and refill rate + - Added `ProtocolBurst` to `TLSRDemand` + - Added `burst` to `MiniProtocolLimits`. Value of Nothing denotes no burst + ability for the protocol, a Just holds a `ProtocolBurst` value. + - Added `miniProtocolWeight` to `MiniProtocolInfo`, denoting the queue weight + the protocol shares with other protocols of the same weight. + - Enhances 'starvation' test to properly handle weighted fair queueing + +--> + + diff --git a/ouroboros-network/changelog.d/20260330_134651_crocodile-dentist_mux_single_peer_performance.md b/ouroboros-network/changelog.d/20260330_134651_crocodile-dentist_mux_single_peer_performance.md new file mode 100644 index 00000000000..8dc740b9aa4 --- /dev/null +++ b/ouroboros-network/changelog.d/20260330_134651_crocodile-dentist_mux_single_peer_performance.md @@ -0,0 +1,23 @@ + + + +### Non-Breaking + +- Integrate weighted fair queue + burst mux + + From a77ca48addd462d25f0420411be0b9a06f9d8885 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 3 Apr 2026 11:11:48 +0200 Subject: [PATCH 08/16] mux: refactoring - SDUWithWantonState * added type signatures * change argument order of `processSingleWanton` * added `SDUWithWantonState` * added bangs to all `go` definitions --- network-mux/src/Network/Mux/Egress.hs | 79 ++++++++++++++++++--------- 1 file changed, 53 insertions(+), 26 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index f51b9972e1f..879c995f7a2 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -172,6 +172,11 @@ sduLength :: SDU -> Int sduLength sdu = fromIntegral msHeaderLength + fromIntegral (msLength sdu) +-- | By forming an `SDU` we also return state of the `Wanton`. +-- +data SDUWithWantonState = EmptyWanton SDU | NonEmptyWanton SDU + + -- | Process the messages from the mini protocols - there is a single -- shared FIFO that contains the items of work. This is processed so -- that each active demand gets a `maxSDU`s work of data processed @@ -206,14 +211,21 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva x:xs -> (x, xs) egressQueues'' | weight > 1 = (pred weight, queue) : rest | otherwise = rest - eSdu <- processSingleWanton sduSize mpc md d + eSdu <- processSingleWanton mpc md d sduSize case eSdu of - Right sdu | pbMaxBytes > 0 -> - -- we do not check if the protocol has any tokens to burst, - -- that is deferred to buildBatch below. - (sdu, egressQueues', True) <$ unGetTBQueue queue demand - | otherwise -> (sdu, egressQueues'', False) <$ writeTBQueue queue demand - Left sdu -> pure (sdu, egressQueues'', False) + NonEmptyWanton sdu + | pbMaxBytes > 0 + -> -- we do not check if the protocol has any tokens to + -- burst, that is deferred to buildBatch below. + (sdu, egressQueues', True) + <$ unGetTBQueue queue demand + + | otherwise + -> (sdu, egressQueues'', False) + <$ writeTBQueue queue demand + + EmptyWanton sdu -> + pure (sdu, egressQueues'', False) (egressQueues'', batch'') <- lift $ buildBatch (mkSingletonBatch sdu) egressQueues' burst start @@ -246,7 +258,11 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva -- (e.g the SO_SNDBUF for Socket) or number of SDUs. -- buildBatch - :: SDUBatch -> [(Word8, EgressQueue m)] -> Bool -> Time -> m ([(Word8, EgressQueue m)], SDUBatch) + :: SDUBatch + -> [(Word8, EgressQueue m)] + -> Bool + -> Time + -> m ([(Word8, EgressQueue m)], SDUBatch) buildBatch batch0 egressQueues1 mBurst0 start = do (qs, batch) <- go batch0 egressQueues1 mBurst0 pure (qs, batch { getSdus = reverse (getSdus batch) }) @@ -257,12 +273,15 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva res <- f x if res then allM f xs else pure False - go :: SDUBatch -> [(Word8, EgressQueue m)] -> Bool -> m ([(Word8, EgressQueue m)], SDUBatch) + go :: SDUBatch + -> [(Word8, EgressQueue m)] + -> Bool + -> m ([(Word8, EgressQueue m)], SDUBatch) go !_batch [] !_burst = error "impossible" - go batch egressQueues _burst + go !batch egressQueues !_burst | getCount batch >= maxSDUsPerBatch || getSdusLength batch >= batchSize - = return (egressQueues, batch) - go batch egressQueues@((weight, queue):rest) mBurst = do + = return (egressQueues, batch) + go !batch egressQueues@((weight, queue):rest) !mBurst = do -- since the list of queues cycles, we only need to check the prefix -- to see if there is any more work to do. allEmpty0 <- atomically $ allM isEmptyTBQueue (snd <$> take numQueues egressQueues) @@ -278,20 +297,29 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva thisEmpty <- isEmptyTBQueue queue let boundedTokens = min sduSize . fromIntegral . min (fromIntegral $ maxBound @SDUSize) - step (!batch', !eSize) mx = do + step :: (SDUBatch, Either SDUSize SDUSize) + -> (SDUSize -> STM m SDUWithWantonState) + -- ^ process one Wanton, `SDUSize` instruments how + -- many bytes take from a `Wanton`. + -> ExceptT (SDUBatch, Bool) + (STM m) + (SDUBatch, Either SDUSize SDUSize) + step (!batch', !eSize) processWanton = do -- the first one is always free -- For Left's, we don't count the wanton bytes against the burst allowance -- to permit a full sdu in the first iteration let (size, consumedTokens) = either (, const 0) (, id) eSize - x <- lift $ mx size + x <- lift $ processWanton size case x of - Left sdu -> do + EmptyWanton sdu -> do + -- the `Wanton` is empty lift $ modifyTVar wBucket \tokens -> let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) tokens' throwE (mkSingletonBatch sdu <> batch', not thisEmpty) - Right sdu -> do + NonEmptyWanton sdu -> do + -- the `Wanton` is non-empty nextSdu <- lift $ stateTVar wBucket \tokens -> let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) @@ -303,6 +331,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva lift $ writeTBQueue queue demand throwE (batch'', True) else pure (batch'', Right nextSdu) + either pure (error "impossible") =<< runExceptT do sduSize0 <- lift $ stateTVar wBucket \tokens -> @@ -321,7 +350,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva lift $ writeTBQueue queue demand throwE (batch, True) foldM step (batch, sduSize0) - (repeat (\sduSize' -> processSingleWanton sduSize' mpc md d)) + (repeat (processSingleWanton mpc md d)) if weight > 1 && goAgain then let egressQueues' = (pred weight, queue) : rest @@ -333,27 +362,25 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva -- data remaining requeue the `TranslocationServiceRequest` (this -- ensures that any other items on the queue will get some service -- first. -processSingleWanton :: (MonadSTM m) - => SDUSize - -> MiniProtocolNum +processSingleWanton :: MonadSTM m + => MiniProtocolNum -> MiniProtocolDir -> Wanton m - -- Right: more sdu's remain; Left: finished - -> STM m (Either SDU SDU) -processSingleWanton sduSize - mpc md wanton = do + -> SDUSize + -> STM m SDUWithWantonState +processSingleWanton mpc md wanton sduSize = do (blob, wrap) <- do -- extract next SDU d <- readTVar (want wanton) let (frag, rest) = BL.splitAt (fromIntegral sduSize) d -- if more to process then enqueue remaining work if BL.null rest - then (frag, Left) <$ writeTVar (want wanton) BL.empty + then (frag, EmptyWanton) <$ writeTVar (want wanton) BL.empty else do -- Note that to preserve bytestream ordering within a given -- miniprotocol the readTVar and writeTVar operations -- must be inside the same STM transaction. - (frag, Right) <$ writeTVar (want wanton) rest + (frag, NonEmptyWanton) <$ writeTVar (want wanton) rest let sdu = SDU { msHeader = SDUHeader { mhTimestamp = RemoteClockModel 0, From 67766401595ef5f721f5e34e0f537ef9a666c132 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 3 Apr 2026 12:04:55 +0200 Subject: [PATCH 09/16] mux: refactoring - NextSDUSize, TokenSize Added dedicated API: * `NextSDUSize`, `nextSDUSizeToSDUSize` * `TokenSize` (type alias), `consumedTokens` --- network-mux/src/Network/Mux/Egress.hs | 84 ++++++++++++++++++++------- 1 file changed, 62 insertions(+), 22 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index 879c995f7a2..d89330ca4df 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -26,7 +26,6 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.State import Data.ByteString.Lazy qualified as BL -import Data.Either (fromRight) import Data.List (tails) import Data.Monoid.Synchronisation import Data.Word (Word32, Word8) @@ -144,7 +143,7 @@ data Wanton m = Wanton { want :: !(StrictTVar m BL.ByteString), wLastSent :: !(StrictTVar m Time), -- ^ the last time the protocol has sent a message - wBucket :: !(StrictTVar m Word32) + wBucket :: !(StrictTVar m TokenSize) -- ^ the number of tokens available to burst } @@ -176,6 +175,38 @@ sduLength sdu = fromIntegral msHeaderLength + fromIntegral (msLength sdu) -- data SDUWithWantonState = EmptyWanton SDU | NonEmptyWanton SDU +-- | Next `SDUSize` when building a batch of `SDU`s +-- +data NextSDUSize + = BurstSize SDUSize + -- ^ Use ` `computeSDUSize` to compute the allowed `SDUSize` + | BearerSize + -- ^ Use `Bearer`'s `sduSize` + +computeSDUSize + :: SDUSize -- ^ Bearer SDUSize + -> TokenSize -- ^ token utilised when building a batch of `SDU`s. + -> SDUSize -- ^ the effective `SDUSize` +computeSDUSize sduSize = + min sduSize + . fromIntegral @TokenSize @SDUSize -- Word32 -> Word16 + . min (fromIntegral @SDUSize @TokenSize maxBound) -- Word16 -> Word32 (but at most Word16) + +nextSDUSizeToSDUSize :: SDUSize -> NextSDUSize -> SDUSize +nextSDUSizeToSDUSize _sduSize (BurstSize sduSize) = sduSize +nextSDUSizeToSDUSize sduSize BearerSize = sduSize +{-# INLINE nextSDUSizeToSDUSize #-} + +type TokenSize = Word32 + +-- | Tokens consumed by an SDU. +-- +consumedTokens :: NextSDUSize -> SDU -> TokenSize +-- in burst mode, we charge tokens based on the SDU payload length +consumedTokens BurstSize{} sdu = fromIntegral (msLength sdu) +-- in non-burst mode, SDU token size is 0 +consumedTokens BearerSize _sdu = 0 +{-# INLINE consumedTokens #-} -- | Process the messages from the mini protocols - there is a single -- shared FIFO that contains the items of work. This is processed so @@ -295,61 +326,70 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva (batch', goAgain) <- atomically do delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) thisEmpty <- isEmptyTBQueue queue - let boundedTokens = min sduSize . fromIntegral . min (fromIntegral $ maxBound @SDUSize) - step :: (SDUBatch, Either SDUSize SDUSize) + let -- take current `SDUBatch` and `NextSDUSize`, and compute + -- the new `SDUBatch` and `NextSDUSize` or return the + -- `SDUBatch` and a boolean value which indicates if any + -- step was taken. + step :: (SDUBatch, NextSDUSize) -> (SDUSize -> STM m SDUWithWantonState) -- ^ process one Wanton, `SDUSize` instruments how -- many bytes take from a `Wanton`. -> ExceptT (SDUBatch, Bool) (STM m) - (SDUBatch, Either SDUSize SDUSize) - step (!batch', !eSize) processWanton = do + (SDUBatch, NextSDUSize) + step (!batch', !nextSDUSize) processWanton = do -- the first one is always free -- For Left's, we don't count the wanton bytes against the burst allowance -- to permit a full sdu in the first iteration - let (size, consumedTokens) = either (, const 0) (, id) eSize - x <- lift $ processWanton size + x <- lift $ processWanton (nextSDUSizeToSDUSize sduSize nextSDUSize) case x of EmptyWanton sdu -> do -- the `Wanton` is empty lift $ modifyTVar wBucket \tokens -> - let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) - in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) + let consumed, tokens' :: TokenSize + consumed = consumedTokens nextSDUSize sdu + tokens' = tokens - consumed + in assert (tokens >= consumed) tokens' throwE (mkSingletonBatch sdu <> batch', not thisEmpty) NonEmptyWanton sdu -> do -- the `Wanton` is non-empty nextSdu <- lift $ stateTVar wBucket \tokens -> - let tokens' = tokens - consumedTokens (fromIntegral (msLength sdu)) - in assert (tokens >= consumedTokens (fromIntegral $ msLength sdu)) - (boundedTokens tokens', tokens') + let consumed, tokens' :: TokenSize + consumed = consumedTokens nextSDUSize sdu + tokens' = tokens - consumed + in assert (tokens >= consumed) + (computeSDUSize sduSize tokens', tokens') let batch'' = mkSingletonBatch sdu <> batch' if nextSdu <= burstMinSdu -- 8 bytes header / 2% burst efficiency then do - -- there is more payload, but burst allowance has been exhausted + -- burst allowance has been exhausted, next + -- SDU would be too small lift $ writeTBQueue queue demand throwE (batch'', True) - else pure (batch'', Right nextSdu) + else pure (batch'', BurstSize nextSdu) either pure (error "impossible") =<< runExceptT do - sduSize0 <- lift $ stateTVar wBucket \tokens -> - let tokens' = truncate $ + nextSduSize <- lift $ stateTVar wBucket \tokens -> + let tokens' :: TokenSize + tokens' = truncate $ min (fromIntegral pbMaxBytes) (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) -- we leverage burst and deduct credits only where there is contention -- between protocols - sduSize0 | mBurst = Right $ boundedTokens tokens' - | otherwise = Left sduSize - in (sduSize0, tokens') - when (fromRight maxBound sduSize0 <= burstMinSdu) do + nextSduSize :: NextSDUSize + nextSduSize | mBurst = BurstSize $ computeSDUSize sduSize tokens' + | otherwise = BearerSize + in (nextSduSize, tokens') + when (nextSDUSizeToSDUSize maxBound nextSduSize <= burstMinSdu) do -- edge case where the protocol is bursty, but there aren't enough tokens -- available. The muxer forever loop does not check this -- when it calls to build a batch, so we handle it here. lift $ writeTBQueue queue demand throwE (batch, True) - foldM step (batch, sduSize0) + foldM step (batch, nextSduSize) (repeat (processSingleWanton mpc md d)) if weight > 1 && goAgain From ef56a32136e0a28691760da22ad42b7bd03e8e5e Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 3 Apr 2026 14:30:57 +0200 Subject: [PATCH 10/16] mux: refactoring - explicit burst loop An explicit loop is easier to follow. We also avoid calling `error "impossible"`. --- network-mux/src/Network/Mux/Egress.hs | 141 +++++++++++++------------- 1 file changed, 70 insertions(+), 71 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index d89330ca4df..e0616519f8f 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -291,11 +291,11 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva buildBatch :: SDUBatch -> [(Word8, EgressQueue m)] - -> Bool + -> Bool -- ^ can we burst -> Time -> m ([(Word8, EgressQueue m)], SDUBatch) - buildBatch batch0 egressQueues1 mBurst0 start = do - (qs, batch) <- go batch0 egressQueues1 mBurst0 + buildBatch batch0 egressQueues1 canBurst0 start = do + (qs, batch) <- go batch0 egressQueues1 canBurst0 pure (qs, batch { getSdus = reverse (getSdus batch) }) where allM f = \case @@ -312,7 +312,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva go !batch egressQueues !_burst | getCount batch >= maxSDUsPerBatch || getSdusLength batch >= batchSize = return (egressQueues, batch) - go !batch egressQueues@((weight, queue):rest) !mBurst = do + go !batch egressQueues@((weight, queue):rest) !canBurst = do -- since the list of queues cycles, we only need to check the prefix -- to see if there is any more work to do. allEmpty0 <- atomically $ allM isEmptyTBQueue (snd <$> take numQueues egressQueues) @@ -322,80 +322,79 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva mResult <- atomically $ tryReadTBQueue queue case mResult of Nothing -> go batch rest False - Just demand@(TLSRDemand mpc md d@Wanton { wLastSent, wBucket } (ProtocolBurst pbMaxBytes pbRefillRate)) -> do + Just demand@(TLSRDemand _ _ + Wanton { wLastSent, wBucket } + ProtocolBurst { pbMaxBytes, pbRefillRate }) -> do (batch', goAgain) <- atomically do delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) - thisEmpty <- isEmptyTBQueue queue - - let -- take current `SDUBatch` and `NextSDUSize`, and compute - -- the new `SDUBatch` and `NextSDUSize` or return the - -- `SDUBatch` and a boolean value which indicates if any - -- step was taken. - step :: (SDUBatch, NextSDUSize) - -> (SDUSize -> STM m SDUWithWantonState) - -- ^ process one Wanton, `SDUSize` instruments how - -- many bytes take from a `Wanton`. - -> ExceptT (SDUBatch, Bool) - (STM m) - (SDUBatch, NextSDUSize) - step (!batch', !nextSDUSize) processWanton = do - -- the first one is always free - -- For Left's, we don't count the wanton bytes against the burst allowance - -- to permit a full sdu in the first iteration - x <- lift $ processWanton (nextSDUSizeToSDUSize sduSize nextSDUSize) - case x of - EmptyWanton sdu -> do - -- the `Wanton` is empty - lift $ modifyTVar wBucket \tokens -> - let consumed, tokens' :: TokenSize - consumed = consumedTokens nextSDUSize sdu - tokens' = tokens - consumed - in assert (tokens >= consumed) - tokens' - throwE (mkSingletonBatch sdu <> batch', not thisEmpty) - NonEmptyWanton sdu -> do - -- the `Wanton` is non-empty - nextSdu <- lift $ stateTVar wBucket \tokens -> - let consumed, tokens' :: TokenSize - consumed = consumedTokens nextSDUSize sdu - tokens' = tokens - consumed - in assert (tokens >= consumed) - (computeSDUSize sduSize tokens', tokens') - let batch'' = mkSingletonBatch sdu <> batch' - if nextSdu <= burstMinSdu -- 8 bytes header / 2% burst efficiency - then do - -- burst allowance has been exhausted, next - -- SDU would be too small - lift $ writeTBQueue queue demand - throwE (batch'', True) - else pure (batch'', BurstSize nextSdu) - - either pure (error "impossible") - =<< runExceptT do - nextSduSize <- lift $ stateTVar wBucket \tokens -> - let tokens' :: TokenSize - tokens' = truncate $ - min (fromIntegral pbMaxBytes) - (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) - -- we leverage burst and deduct credits only where there is contention - -- between protocols - nextSduSize :: NextSDUSize - nextSduSize | mBurst = BurstSize $ computeSDUSize sduSize tokens' - | otherwise = BearerSize - in (nextSduSize, tokens') - when (nextSDUSizeToSDUSize maxBound nextSduSize <= burstMinSdu) do - -- edge case where the protocol is bursty, but there aren't enough tokens - -- available. The muxer forever loop does not check this - -- when it calls to build a batch, so we handle it here. - lift $ writeTBQueue queue demand - throwE (batch, True) - foldM step (batch, nextSduSize) - (repeat (processSingleWanton mpc md d)) + + nextSduSize <- stateTVar wBucket \tokens -> + let tokens' :: TokenSize + tokens' = truncate $ + min (fromIntegral pbMaxBytes) + (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) + -- we leverage burst and deduct credits only where there is contention + -- between protocols + nextSduSize :: NextSDUSize + nextSduSize | canBurst = BurstSize $ computeSDUSize sduSize tokens' + | otherwise = BearerSize + in (nextSduSize, tokens') + if nextSDUSizeToSDUSize maxBound nextSduSize <= burstMinSdu + then do + -- edge case where the protocol is bursty, but there aren't enough tokens + -- available. The muxer forever loop does not check this + -- when it calls to build a batch, so we handle it here. + writeTBQueue queue demand + return (batch, True) + else + burstLoop demand batch nextSduSize if weight > 1 && goAgain then let egressQueues' = (pred weight, queue) : rest in go batch' egressQueues' False else go batch' rest False + where + -- burst SDUs from a single mini-protocol until we consume all tokens + -- (`TokenSize`). + burstLoop :: TranslocationServiceRequest m + -> SDUBatch + -> NextSDUSize + -> STM m (SDUBatch, Bool) + burstLoop demand@(TLSRDemand miniProtocolNum miniProtocolDir want@Wanton {wBucket} _) !batch' !nextSDUSize = do + -- The first SDU is always free. For `BearerSize` (no bursting), + -- we don't count the wanton bytes against the burst allowance + -- to permit a full sdu in the first iteration + x <- processSingleWanton miniProtocolNum miniProtocolDir + want + (nextSDUSizeToSDUSize sduSize nextSDUSize) + case x of + EmptyWanton sdu -> do + -- the `Wanton` is empty + modifyTVar wBucket \tokens -> + let consumed, tokens' :: TokenSize + consumed = consumedTokens nextSDUSize sdu + tokens' = tokens - consumed + in assert (tokens >= consumed) + tokens' + thisEmpty <- isEmptyTBQueue queue + return (mkSingletonBatch sdu <> batch', not thisEmpty) + + NonEmptyWanton sdu -> do + -- the `Wanton` is non-empty + nextSdu <- stateTVar wBucket \tokens -> + let consumed, tokens' :: TokenSize + consumed = consumedTokens nextSDUSize sdu + tokens' = tokens - consumed + in assert (tokens >= consumed) + (computeSDUSize sduSize tokens', tokens') + let batch'' = mkSingletonBatch sdu <> batch' + if nextSdu <= burstMinSdu -- 8 bytes header / 2% burst efficiency + then do + -- burst allowance has been exhausted, next + -- SDU would be too small + writeTBQueue queue demand + return (batch'', True) + else burstLoop demand batch'' (BurstSize nextSdu) -- | Pull a `maxSDU`s worth of data out out the `Wanton` - if there is From 0386b0827ba910f67eab1720cc4dd8dabe94457c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 3 Apr 2026 15:14:40 +0200 Subject: [PATCH 11/16] mux: refactoring - replaced custom allM Replaced a custom `allM` with `foldMap All . traverse`. In the future we can fuse `foldMap` with `traverse`. --- network-mux/src/Network/Mux/Egress.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index e0616519f8f..6db0d2f8946 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -23,10 +23,10 @@ import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Trans.Class -import Control.Monad.Trans.Except import Control.Monad.Trans.State import Data.ByteString.Lazy qualified as BL import Data.List (tails) +import Data.Monoid (All (..), Ap (..)) import Data.Monoid.Synchronisation import Data.Word (Word32, Word8) @@ -298,12 +298,6 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva (qs, batch) <- go batch0 egressQueues1 canBurst0 pure (qs, batch { getSdus = reverse (getSdus batch) }) where - allM f = \case - [] -> pure True - (x:xs) -> do - res <- f x - if res then allM f xs else pure False - go :: SDUBatch -> [(Word8, EgressQueue m)] -> Bool @@ -315,7 +309,12 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva go !batch egressQueues@((weight, queue):rest) !canBurst = do -- since the list of queues cycles, we only need to check the prefix -- to see if there is any more work to do. - allEmpty0 <- atomically $ allM isEmptyTBQueue (snd <$> take numQueues egressQueues) + -- + -- TODO: we could use `atomically $ foldMap (fmap All . isEmptyTBQueue + -- . snd)` if `transformers` had `Monoid a => Monoid (m a)` instance. + All allEmpty0 <- + atomically $ getAp $ foldMap (Ap . fmap All . isEmptyTBQueue . snd) + (take numQueues egressQueues) if allEmpty0 then return (egressQueues, batch) else do From d1e1d0e42255548108f3c0c4422fa624e37aeda3 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 3 Apr 2026 15:38:31 +0200 Subject: [PATCH 12/16] mux: refactoring - moved constants Move constants to top level bindings: * `maxSDUsPerBatch` * `burstMinSdu` --- network-mux/src/Network/Mux/Egress.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index 6db0d2f8946..2bca946298d 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -208,6 +208,18 @@ consumedTokens BurstSize{} sdu = fromIntegral (msLength sdu) consumedTokens BearerSize _sdu = 0 {-# INLINE consumedTokens #-} + +-- | Maximal number of `SDU`s in a `SDUBatch`. +-- +maxSDUsPerBatch :: Int +maxSDUsPerBatch = 100 + +-- | Minimal SDUSize for an SDU to be burst. +-- +burstMinSdu :: SDUSize +burstMinSdu = truncate @Double $ fromIntegral msHeaderLength / 0.02 + + -- | Process the messages from the mini protocols - there is a single -- shared FIFO that contains the items of work. This is processed so -- that each active demand gets a `maxSDU`s work of data processed @@ -269,14 +281,9 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva numQueues :: Int numQueues = length egressQueues0 - maxSDUsPerBatch :: Int - maxSDUsPerBatch = 100 - toDouble :: DiffTime -> Double toDouble = realToFrac - burstMinSdu = truncate @Double @SDUSize $ fromIntegral msHeaderLength / 0.02 - -- Build a batch of SDUs to submit in one go to the bearer. -- Streams which are permitted to burst will have that many -- sdu's serviced back-to-back before the scheduler moves to process the From 3335505a64ee860669f1e0cd92a4da738c1bb77a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 3 Apr 2026 16:59:43 +0200 Subject: [PATCH 13/16] mux: refactoring - CanBatch, CanBurst Replaced `Bool` with: * `CanBatch` - can we batch more SDUs from different mini-protocols. * `CanBurst` - can we burst more SDUs from a single mini-protocol. --- network-mux/src/Network/Mux/Egress.hs | 75 +++++++++++++++++---------- 1 file changed, 47 insertions(+), 28 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index 2bca946298d..00da1422872 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -209,6 +209,18 @@ consumedTokens BearerSize _sdu = 0 {-# INLINE consumedTokens #-} +-- | Can we burst a single mini-protocol. +-- +data CanBurst = BurstAllowed + | BurstNotAllowed + + +-- | Can we batch more SDUs from different mini-protocols. +-- +data CanBatch = BatchAllowed + | BatchNotAllowed + + -- | Maximal number of `SDU`s in a `SDUBatch`. -- maxSDUsPerBatch :: Int @@ -245,7 +257,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva (zip (tails egressQueues) (take numQueues (snd <$> egressQueues))) start <- lift getMonotonicTime - (sdu, egressQueues', burst) <- lift $ atomically do + (sdu, egressQueues', canBatch) <- lift $ atomically do job <- runFirstToFinish jobs case job of (egressQueues', demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate))) -> do @@ -260,18 +272,18 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva | pbMaxBytes > 0 -> -- we do not check if the protocol has any tokens to -- burst, that is deferred to buildBatch below. - (sdu, egressQueues', True) + (sdu, egressQueues', BatchAllowed) <$ unGetTBQueue queue demand | otherwise - -> (sdu, egressQueues'', False) + -> (sdu, egressQueues'', BatchNotAllowed) <$ writeTBQueue queue demand EmptyWanton sdu -> - pure (sdu, egressQueues'', False) + pure (sdu, egressQueues'', BatchNotAllowed) (egressQueues'', batch'') <- - lift $ buildBatch (mkSingletonBatch sdu) egressQueues' burst start + lift $ buildBatch (mkSingletonBatch sdu) egressQueues' canBatch start put egressQueues'' void . lift $ writeMany tracer timeout (getSdus batch'') delta <- (`diffTime` start) <$> lift getMonotonicTime @@ -298,27 +310,24 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva buildBatch :: SDUBatch -> [(Word8, EgressQueue m)] - -> Bool -- ^ can we burst + -> CanBatch -- ^ can we batch more SDUs -> Time -> m ([(Word8, EgressQueue m)], SDUBatch) - buildBatch batch0 egressQueues1 canBurst0 start = do - (qs, batch) <- go batch0 egressQueues1 canBurst0 + buildBatch batch0 egressQueues1 canBatch0 start = do + (qs, batch) <- go batch0 egressQueues1 canBatch0 pure (qs, batch { getSdus = reverse (getSdus batch) }) where go :: SDUBatch -> [(Word8, EgressQueue m)] - -> Bool + -> CanBatch -> m ([(Word8, EgressQueue m)], SDUBatch) - go !_batch [] !_burst = error "impossible" - go !batch egressQueues !_burst + go !_batch [] !_canBatch = error "impossible" + go !batch egressQueues !_canBatch | getCount batch >= maxSDUsPerBatch || getSdusLength batch >= batchSize = return (egressQueues, batch) - go !batch egressQueues@((weight, queue):rest) !canBurst = do + go !batch egressQueues@((weight, queue):rest) !canBatch = do -- since the list of queues cycles, we only need to check the prefix -- to see if there is any more work to do. - -- - -- TODO: we could use `atomically $ foldMap (fmap All . isEmptyTBQueue - -- . snd)` if `transformers` had `Monoid a => Monoid (m a)` instance. All allEmpty0 <- atomically $ getAp $ foldMap (Ap . fmap All . isEmptyTBQueue . snd) (take numQueues egressQueues) @@ -327,11 +336,11 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva else do mResult <- atomically $ tryReadTBQueue queue case mResult of - Nothing -> go batch rest False + Nothing -> go batch rest BatchNotAllowed Just demand@(TLSRDemand _ _ Wanton { wLastSent, wBucket } ProtocolBurst { pbMaxBytes, pbRefillRate }) -> do - (batch', goAgain) <- atomically do + (batch', canBurst) <- atomically do delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) nextSduSize <- stateTVar wBucket \tokens -> @@ -342,8 +351,10 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva -- we leverage burst and deduct credits only where there is contention -- between protocols nextSduSize :: NextSDUSize - nextSduSize | canBurst = BurstSize $ computeSDUSize sduSize tokens' - | otherwise = BearerSize + nextSduSize = + case canBatch of + BatchAllowed -> BurstSize $ computeSDUSize sduSize tokens' + BatchNotAllowed -> BearerSize in (nextSduSize, tokens') if nextSDUSizeToSDUSize maxBound nextSduSize <= burstMinSdu then do @@ -351,21 +362,26 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva -- available. The muxer forever loop does not check this -- when it calls to build a batch, so we handle it here. writeTBQueue queue demand - return (batch, True) + return (batch, BurstAllowed) else burstLoop demand batch nextSduSize - if weight > 1 && goAgain - then let egressQueues' = (pred weight, queue) : rest - in go batch' egressQueues' False - else go batch' rest False + case canBurst of + BurstAllowed + | weight > 1 -> + let egressQueues' = (pred weight, queue) : rest in + go batch' egressQueues' BatchNotAllowed + | otherwise -> + go batch' rest BatchNotAllowed + BurstNotAllowed -> + go batch' rest BatchNotAllowed where -- burst SDUs from a single mini-protocol until we consume all tokens -- (`TokenSize`). burstLoop :: TranslocationServiceRequest m -> SDUBatch -> NextSDUSize - -> STM m (SDUBatch, Bool) + -> STM m (SDUBatch, CanBurst) burstLoop demand@(TLSRDemand miniProtocolNum miniProtocolDir want@Wanton {wBucket} _) !batch' !nextSDUSize = do -- The first SDU is always free. For `BearerSize` (no bursting), -- we don't count the wanton bytes against the burst allowance @@ -382,8 +398,11 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva tokens' = tokens - consumed in assert (tokens >= consumed) tokens' - thisEmpty <- isEmptyTBQueue queue - return (mkSingletonBatch sdu <> batch', not thisEmpty) + continue <- (\case + True -> BurstNotAllowed + False -> BurstAllowed) + <$> isEmptyTBQueue queue + return (mkSingletonBatch sdu <> batch', continue) NonEmptyWanton sdu -> do -- the `Wanton` is non-empty @@ -399,7 +418,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva -- burst allowance has been exhausted, next -- SDU would be too small writeTBQueue queue demand - return (batch'', True) + return (batch'', BurstAllowed) else burstLoop demand batch'' (BurstSize nextSdu) From f3d07ee22fbe484ec92998570873e132254f66e1 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 7 Apr 2026 14:00:03 +0200 Subject: [PATCH 14/16] mux: refactoring - explicit muxer loop Use an explicit loop in `muxer`, as a result `transformers` dependency is gone. --- network-mux/network-mux.cabal | 1 - network-mux/src/Network/Mux/Egress.hs | 46 ++++++++++++++------------- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 5fb51ed3757..76b152d0e0f 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -67,7 +67,6 @@ library statistics-linreg >=0.3 && <0.4, strict, time >=1.9.1 && <1.16, - transformers, vector >=0.12 && <0.14, if os(windows) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index 00da1422872..e1e083c604e 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -21,9 +21,6 @@ module Network.Mux.Egress import Control.Applicative import Control.Exception -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.State import Data.ByteString.Lazy qualified as BL import Data.List (tails) import Data.Monoid (All (..), Ap (..)) @@ -251,13 +248,25 @@ muxer -> Bearer m -> m void muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterval } = - withTimeoutSerial $ \timeout -> (`evalStateT` cycle egressQueues0) $ forever do - egressQueues <- get - let jobs = foldMap (FirstToFinish . traverse readTBQueue) - (zip (tails egressQueues) (take numQueues (snd <$> egressQueues))) + withTimeoutSerial $ \timeout -> muxerLoop timeout (cycle egressQueues0) + where + numQueues :: Int + numQueues = length egressQueues0 + toDouble :: DiffTime -> Double + toDouble = realToFrac - start <- lift getMonotonicTime - (sdu, egressQueues', canBatch) <- lift $ atomically do + -- main muxer loop + muxerLoop :: (forall a. DiffTime -> m a -> m (Maybe a)) + -> [(Word8, EgressQueue m)] + -- ^ a cycle of egress queues + -> m void + muxerLoop timeout egressQueues = do + start <- getMonotonicTime + (sdu, egressQueues', canBatch) <- atomically do + let jobs :: FirstToFinish (STM m) + ([(Word8, EgressQueue m)], TranslocationServiceRequest m) + jobs = foldMap (FirstToFinish . traverse readTBQueue) + (zip (tails egressQueues) (take numQueues (snd <$> egressQueues))) job <- runFirstToFinish jobs case job of (egressQueues', demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate))) -> do @@ -282,19 +291,12 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva EmptyWanton sdu -> pure (sdu, egressQueues'', BatchNotAllowed) - (egressQueues'', batch'') <- - lift $ buildBatch (mkSingletonBatch sdu) egressQueues' canBatch start - put egressQueues'' - void . lift $ writeMany tracer timeout (getSdus batch'') - delta <- (`diffTime` start) <$> lift getMonotonicTime - lift . threadDelay $ egressInterval - delta - - where - numQueues :: Int - numQueues = length egressQueues0 - - toDouble :: DiffTime -> Double - toDouble = realToFrac + (egressQueues'', SDUBatch { getSdus = sdus }) <- + buildBatch (mkSingletonBatch sdu) egressQueues' canBatch start + _ <- writeMany tracer timeout sdus + end <- getMonotonicTime + threadDelay $ egressInterval - end `diffTime` start + muxerLoop timeout egressQueues'' -- Build a batch of SDUs to submit in one go to the bearer. -- Streams which are permitted to burst will have that many From 63fad3f94865a17f7c94a205175194a81b7e9126 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 7 Apr 2026 14:20:14 +0200 Subject: [PATCH 15/16] mux: refactoring - muxer loop Refactor `muxerLoop` It's easier to read `[(EgressQueue m, [(Word8, Egress m)])]`, than the other way around, since then it's the `EgressQueue` we read and its tail much like `x : xs`. This also avoids using `traverse` over tuple which is a bit surprising. --- network-mux/src/Network/Mux/Egress.hs | 38 ++++++++++++++++++--------- 1 file changed, 26 insertions(+), 12 deletions(-) diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index e1e083c604e..65595e5e4f7 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -263,17 +263,31 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva muxerLoop timeout egressQueues = do start <- getMonotonicTime (sdu, egressQueues', canBatch) <- atomically do - let jobs :: FirstToFinish (STM m) - ([(Word8, EgressQueue m)], TranslocationServiceRequest m) - jobs = foldMap (FirstToFinish . traverse readTBQueue) - (zip (tails egressQueues) (take numQueues (snd <$> egressQueues))) - job <- runFirstToFinish jobs + let -- All distinct `EgressQueue`s and their tail (so we keep reading + -- them in a round robin way). + available :: [(EgressQueue m, [(Word8, EgressQueue m)])] + available = take numQueues (snd <$> egressQueues) + `zip` + tails egressQueues + + -- read first available `EgressQueue` and return its tail + job <- runFirstToFinish + . foldMap + ( FirstToFinish + . \(egressQueue, egressQueues') -> + (,egressQueues') <$> readTBQueue egressQueue + ) + $ available case job of - (egressQueues', demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate))) -> do - let ((weight, queue), rest) = assert (weight > 0) case egressQueues' of - [] -> error "impossible" - x:xs -> (x, xs) - egressQueues'' | weight > 1 = (pred weight, queue) : rest + (demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate)) + , egressQueues' + ) -> do + let ((weight, egressQueue), rest) = assert (weight > 0) + case egressQueues' of + [] -> error "impossible" + x:xs -> (x, xs) + egressQueues'' | weight > 1 = (pred weight, egressQueue) + : rest | otherwise = rest eSdu <- processSingleWanton mpc md d sduSize case eSdu of @@ -282,11 +296,11 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva -> -- we do not check if the protocol has any tokens to -- burst, that is deferred to buildBatch below. (sdu, egressQueues', BatchAllowed) - <$ unGetTBQueue queue demand + <$ unGetTBQueue egressQueue demand | otherwise -> (sdu, egressQueues'', BatchNotAllowed) - <$ writeTBQueue queue demand + <$ writeTBQueue egressQueue demand EmptyWanton sdu -> pure (sdu, egressQueues'', BatchNotAllowed) From 20e116a887b695e87bf1f1b4f3a32e0b96f568b0 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 8 Apr 2026 10:18:26 +0200 Subject: [PATCH 16/16] mux: refactoring - added record fields Use DuplicateRecordFields for: * `Wanton` * `TranslocationServiceRequest` * `ProtocolBurst` These are all internal data types, so we won't force it on `network-mux` user. --- network-mux/src/Network/Mux.hs | 1 + network-mux/src/Network/Mux/Egress.hs | 62 ++++++++++++++++----------- network-mux/src/Network/Mux/Types.hs | 8 ++-- 3 files changed, 41 insertions(+), 30 deletions(-) diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 4c1b3f7d0f9..7e1e7790b49 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTSyntax #-} diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index 65595e5e4f7..d837d11f5bb 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -130,18 +131,23 @@ type EgressQueue m = StrictTBQueue m (TranslocationServiceRequest m) -- arbitrary (yet bounded) size. This multiplexing layer is -- responsible for the segmentation of concrete representation into -- appropriate SDU's for onward transmission. -data TranslocationServiceRequest m = - TLSRDemand !MiniProtocolNum !MiniProtocolDir !(Wanton m) !ProtocolBurst +data TranslocationServiceRequest m = TLSRDemand { + miniProtocolNum :: !MiniProtocolNum, + miniProtocolDir :: !MiniProtocolDir, + wanton :: !(Wanton m), + protocolBurst :: !ProtocolBurst + } -- | A Wanton represent the concrete data to be translocated, note that the -- TVar becoming empty indicates -- that the last fragment of the data has -- been enqueued on the -- underlying bearer. data Wanton m = Wanton { - want :: !(StrictTVar m BL.ByteString), - wLastSent :: !(StrictTVar m Time), - -- ^ the last time the protocol has sent a message - wBucket :: !(StrictTVar m TokenSize) - -- ^ the number of tokens available to burst + wanton :: !(StrictTVar m BL.ByteString), + -- ^ data buffer + lastSent :: !(StrictTVar m Time), + -- ^ the last time the protocol has sent a message + burstBucket :: !(StrictTVar m TokenSize) + -- ^ the number of tokens available to burst } @@ -279,7 +285,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva ) $ available case job of - (demand@(TLSRDemand mpc md d (ProtocolBurst pbMaxBytes _pbRefillRate)) + (demand@(TLSRDemand mpc md d ProtocolBurst{maxBytes}) , egressQueues' ) -> do let ((weight, egressQueue), rest) = assert (weight > 0) @@ -292,7 +298,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva eSdu <- processSingleWanton mpc md d sduSize case eSdu of NonEmptyWanton sdu - | pbMaxBytes > 0 + | maxBytes > 0 -> -- we do not check if the protocol has any tokens to -- burst, that is deferred to buildBatch below. (sdu, egressQueues', BatchAllowed) @@ -349,21 +355,21 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva (take numQueues egressQueues) if allEmpty0 then return (egressQueues, batch) - else do - mResult <- atomically $ tryReadTBQueue queue - case mResult of + else + atomically (tryReadTBQueue queue) >>= \case Nothing -> go batch rest BatchNotAllowed - Just demand@(TLSRDemand _ _ - Wanton { wLastSent, wBucket } - ProtocolBurst { pbMaxBytes, pbRefillRate }) -> do + Just demand@TLSRDemand { + wanton = Wanton { lastSent, burstBucket }, + protocolBurst = ProtocolBurst { maxBytes, refillRate } + } -> do (batch', canBurst) <- atomically do - delta <- (start `diffTime`) <$> stateTVar wLastSent (, start) + delta <- (start `diffTime`) <$> stateTVar lastSent (, start) - nextSduSize <- stateTVar wBucket \tokens -> + nextSduSize <- stateTVar burstBucket \tokens -> let tokens' :: TokenSize tokens' = truncate $ - min (fromIntegral pbMaxBytes) - (fromIntegral tokens + fromIntegral pbRefillRate * toDouble delta) + min (fromIntegral maxBytes) + (fromIntegral tokens + fromIntegral refillRate * toDouble delta) -- we leverage burst and deduct credits only where there is contention -- between protocols nextSduSize :: NextSDUSize @@ -398,7 +404,11 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva -> SDUBatch -> NextSDUSize -> STM m (SDUBatch, CanBurst) - burstLoop demand@(TLSRDemand miniProtocolNum miniProtocolDir want@Wanton {wBucket} _) !batch' !nextSDUSize = do + burstLoop demand@TLSRDemand { miniProtocolNum, + miniProtocolDir, + wanton = want@Wanton {burstBucket} + } + !batch' !nextSDUSize = do -- The first SDU is always free. For `BearerSize` (no bursting), -- we don't count the wanton bytes against the burst allowance -- to permit a full sdu in the first iteration @@ -408,7 +418,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva case x of EmptyWanton sdu -> do -- the `Wanton` is empty - modifyTVar wBucket \tokens -> + modifyTVar burstBucket \tokens -> let consumed, tokens' :: TokenSize consumed = consumedTokens nextSDUSize sdu tokens' = tokens - consumed @@ -422,7 +432,7 @@ muxer egressQueues0 tracer Bearer { writeMany, sduSize, batchSize, egressInterva NonEmptyWanton sdu -> do -- the `Wanton` is non-empty - nextSdu <- stateTVar wBucket \tokens -> + nextSdu <- stateTVar burstBucket \tokens -> let consumed, tokens' :: TokenSize consumed = consumedTokens nextSDUSize sdu tokens' = tokens - consumed @@ -448,19 +458,19 @@ processSingleWanton :: MonadSTM m -> Wanton m -> SDUSize -> STM m SDUWithWantonState -processSingleWanton mpc md wanton sduSize = do +processSingleWanton mpc md Wanton{wanton} sduSize = do (blob, wrap) <- do -- extract next SDU - d <- readTVar (want wanton) + d <- readTVar wanton let (frag, rest) = BL.splitAt (fromIntegral sduSize) d -- if more to process then enqueue remaining work if BL.null rest - then (frag, EmptyWanton) <$ writeTVar (want wanton) BL.empty + then (frag, EmptyWanton) <$ writeTVar wanton BL.empty else do -- Note that to preserve bytestream ordering within a given -- miniprotocol the readTVar and writeTVar operations -- must be inside the same STM transaction. - (frag, NonEmptyWanton) <$ writeTVar (want wanton) rest + (frag, NonEmptyWanton) <$ writeTVar wanton rest let sdu = SDU { msHeader = SDUHeader { mhTimestamp = RemoteClockModel 0, diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs index 61b60de28c8..4af8c9cfd94 100644 --- a/network-mux/src/Network/Mux/Types.hs +++ b/network-mux/src/Network/Mux/Types.hs @@ -106,10 +106,10 @@ data MiniProtocolLimits = data ProtocolBurst = ProtocolBurst { - pbMaxBytes :: !Word32, - -- ^ token bucket max size - pbRefillRate :: !Word32 - -- ^ token bucket refill rate, [1/s] + maxBytes :: !Word32, + -- ^ token bucket max size + refillRate :: !Word32 + -- ^ token bucket refill rate, [1/s] } deriving (Eq, Show)