From 926b3a0f191b69129d1691174c1996411ab2b4bf Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 29 Aug 2025 16:21:42 +0200 Subject: [PATCH 1/3] sim-benchmarks: refactor PeerMetrics benchmarks Use `env`, rather than storing data on heap for whole run of all benchmarks. --- .../ouroboros-network-testing.cabal | 1 + .../src/Test/Ouroboros/Network/Data/Script.hs | 9 +++++--- ouroboros-network/bench/Main.hs | 23 +++++++++---------- .../Network/PeerSelection/PeerMetric.hs | 11 +++++++-- 4 files changed, 27 insertions(+), 17 deletions(-) diff --git a/ouroboros-network-testing/ouroboros-network-testing.cabal b/ouroboros-network-testing/ouroboros-network-testing.cabal index 547ba6de25b..d0afcf21123 100644 --- a/ouroboros-network-testing/ouroboros-network-testing.cabal +++ b/ouroboros-network-testing/ouroboros-network-testing.cabal @@ -68,6 +68,7 @@ library cborg >=0.2.1 && <0.3, containers, contra-tracer, + deepseq, deque ^>=0.4, io-classes:{io-classes, si-timers, strict-stm} ^>=1.8.0.1, io-sim, diff --git a/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/Script.hs b/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/Script.hs index 2d72fd16dff..a28b6f76a98 100644 --- a/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/Script.hs +++ b/ouroboros-network-testing/src/Test/Ouroboros/Network/Data/Script.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} module Test.Ouroboros.Network.Data.Script ( -- * Test scripts @@ -40,6 +41,7 @@ import Data.Set qualified as Set import Control.Concurrent.Class.MonadSTM (TVar) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict +import Control.DeepSeq import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadTimer.SI @@ -55,6 +57,7 @@ import Test.QuickCheck newtype Script a = Script (NonEmpty a) deriving (Eq, Show, Functor, Foldable, Traversable) + deriving newtype NFData singletonScript :: a -> Script a singletonScript x = Script (x :| []) diff --git a/ouroboros-network/bench/Main.hs b/ouroboros-network/bench/Main.hs index d72ec17fbaf..5e89c4376d0 100644 --- a/ouroboros-network/bench/Main.hs +++ b/ouroboros-network/bench/Main.hs @@ -8,17 +8,16 @@ import Test.Ouroboros.Network.PeerSelection.PeerMetric (microbenchmark1GenerateInput, microbenchmark1ProcessInput) main :: IO () -main = do - is <- mapM (microbenchmark1GenerateInput False . snd) benchmarks +main = defaultMain - [bgroup "ouroboros-network:sim-benchmarks" - [ bench (unwords ["microbenchmark1",name]) - $ nfAppIO microbenchmark1ProcessInput i - | ((name,_),i) <- zip benchmarks is - ] + [ bgroup "ouroboros-network:sim-benchmarks" + [ bgroup "PeerMetrics" + [ env (microbenchmark1GenerateInput False 1_000) $ \i -> + bench "1k" $ nfAppIO microbenchmark1ProcessInput i + , env (microbenchmark1GenerateInput False 10_000) $ \i -> + bench "10k" $ nfAppIO microbenchmark1ProcessInput i + , env (microbenchmark1GenerateInput False 100_000) $ \i -> + bench "100k" $ nfAppIO microbenchmark1ProcessInput i + ] + ] ] - where - benchmarks = [("1k" , 1000) - ,("10k" , 10_000) - ,("100k",100_000) - ] diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index 8da417642b3..522a59de869 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -27,6 +29,7 @@ import Data.Map.Merge.Strict qualified as Map import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set qualified as Set +import GHC.Generics import Network.Mux.Trace (TraceLabelPeer (..)) @@ -73,7 +76,7 @@ instance Arbitrary TestAddress where data Event = FetchedHeader TestAddress SlotNo | FetchedBlock TestAddress SlotNo SizeInBytes - deriving Show + deriving (Show, Generic, NFData) eventPeer :: Event -> TestAddress eventPeer (FetchedHeader peer _) = peer @@ -100,6 +103,7 @@ instance Arbitrary Event where newtype FixedScript = FixedScript { getFixedScript :: Script Event } deriving Show + deriving newtype NFData -- | Order events by 'SlotNo' -- @@ -446,9 +450,12 @@ microbenchmark1GenerateInput verbose' n = do mapM_ print (let FixedScript s = fixedScript in s) return fixedScript +-- TODO: +-- * we shouldn't use QuickCheck +-- * and we shouldn't use IOSim (which `prop_simScript`) is using. microbenchmark1ProcessInput :: FixedScript -> IO () microbenchmark1ProcessInput = - quickCheckWith (stdArgs{maxSuccess=1}) . prop_simScript + quickCheckWith (stdArgs{maxSuccess=1,chatty=False}) . prop_simScript microbenchmark1 :: Bool -> Int -> IO () microbenchmark1 verbose' n = From 9b8ccd637ba1b9a58b8d87771c06f988e0e98a1f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 29 Aug 2025 16:34:52 +0200 Subject: [PATCH 2/3] sim-benchmarks: use threaded RTS When using non-threaded RTS, an eventlog file can be corrupted, and thus unparsable by other tools, like `eventlog2html`. --- ouroboros-network/ouroboros-network.cabal | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 9d3a5691e84..8a0a31c819b 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -509,15 +509,16 @@ benchmark sim-benchmarks ouroboros-network:testlib, tasty-bench >=0.3.5, + -- We use `-fproc-alignemtn` option to avoid skewed results due to changes in cache-line + -- alignment. See https://github.com/Bodigrim/tasty-bench#comparison-against-baseline + -- We use threaded RTS, because of + -- https://gitlab.haskell.org/ghc/ghc/-/issues/25165 ghc-options: -fno-ignore-asserts + -threaded + -rtsopts -with-rtsopts=-A32m + -fproc-alignment=64 +RTS -T -RTS - - -- We use this option to avoid skewed results due to changes in cache-line - -- alignment. See - -- https://github.com/Bodigrim/tasty-bench#comparison-against-baseline - if impl(ghc >=8.6) - ghc-options: -fproc-alignment=64 From d1bc0a766422f371892bc7adf997ffbad75855ab Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 29 Aug 2025 11:46:12 +0200 Subject: [PATCH 3/3] tx-submission: micro benchmark for makeDecisions --- ouroboros-network/bench/Main.hs | 51 +++++++++++++++++++ ouroboros-network/ouroboros-network.cabal | 5 +- .../TxSubmission/Inbound/V2/Decision.hs | 14 ++--- .../Network/TxSubmission/Inbound/V2/Policy.hs | 4 ++ .../Network/TxSubmission/Inbound/V2/State.hs | 16 +++--- .../Network/TxSubmission/Inbound/V2/Types.hs | 12 +++-- .../Network/PeerSelection/PeerMetric.hs | 2 +- .../Ouroboros/Network/TxSubmission/TxLogic.hs | 24 +++++++++ .../Ouroboros/Network/TxSubmission/Types.hs | 4 +- 9 files changed, 114 insertions(+), 18 deletions(-) diff --git a/ouroboros-network/bench/Main.hs b/ouroboros-network/bench/Main.hs index 5e89c4376d0..87ad6a34340 100644 --- a/ouroboros-network/bench/Main.hs +++ b/ouroboros-network/bench/Main.hs @@ -2,8 +2,16 @@ module Main (main) where +import Control.DeepSeq +import Control.Exception (evaluate) +import Debug.Trace (traceMarkerIO) +import System.Random.SplitMix qualified as SM import Test.Tasty.Bench +import Ouroboros.Network.TxSubmission.Inbound.V2.Decision qualified as Tx +import Test.Ouroboros.Network.TxSubmission.TxLogic qualified as TX + (mkDecisionContext) + import Test.Ouroboros.Network.PeerSelection.PeerMetric (microbenchmark1GenerateInput, microbenchmark1ProcessInput) @@ -19,5 +27,48 @@ main = , env (microbenchmark1GenerateInput False 100_000) $ \i -> bench "100k" $ nfAppIO microbenchmark1ProcessInput i ] + , bgroup "TxLogic" + [ env (do let a = TX.mkDecisionContext (SM.mkSMGen 131) 10 + evaluate (rnf a) + traceMarkerIO "evaluated decision context" + return a + ) + (\a -> + bench "makeDecisions: 10" + $ nf (uncurry Tx.makeDecisions) a + ) + , env (do let a = TX.mkDecisionContext (SM.mkSMGen 131) 100 + evaluate (rnf a) + traceMarkerIO "evaluated decision context" + return a + ) + (\a -> + bench "makeDecisions: 100" + $ nf (uncurry Tx.makeDecisions) a + ) + , env (do let a = TX.mkDecisionContext (SM.mkSMGen 361) 1_000 + evaluate (rnf a) + traceMarkerIO "evaluated decision context" + return a + ) + (\a -> + bench "makeDecisions: 1000" + $ nf (uncurry Tx.makeDecisions) a + ) +{- + , env (do + smGen <- SM.initSMGen + print smGen + let a = TX.mkDecisionContext smGen 1000 + evaluate (rnf a) + traceMarkerIO "evaluated decision context" + return a + ) + (\a -> + bench "makeDecisions: random" + $ nf (uncurry Tx.makeDecisions) a + ) +-} + ] ] ] diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 8a0a31c819b..63613def988 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -345,6 +345,7 @@ library testlib psqueues, random, serialise, + splitmix, tasty, tasty-hunit, tasty-quickcheck, @@ -506,7 +507,9 @@ benchmark sim-benchmarks main-is: Main.hs build-depends: base, - ouroboros-network:testlib, + deepseq, + ouroboros-network:{ouroboros-network, testlib}, + splitmix, tasty-bench >=0.3.5, -- We use `-fproc-alignemtn` option to avoid skewed results due to changes in cache-line diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs index cb8c9bc4f1c..4bed1fc31bc 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Decision.hs @@ -84,7 +84,7 @@ makeDecisions policy st = orderByRejections :: Hashable peeraddr => Int -> Map peeraddr (PeerTxState txid tx) - -> [ (peeraddr, PeerTxState txid tx)] + -> [(peeraddr, PeerTxState txid tx)] orderByRejections salt = List.sortOn (\(peeraddr, ps) -> (score ps, hashWithSalt salt peeraddr)) . Map.toList @@ -103,7 +103,7 @@ data St peeraddr txid tx = -- ^ acknowledged `txid` with multiplicities. It is used to update -- `referenceCounts`. - stInSubmissionToMempoolTxs :: Set txid + stInSubmissionToMempoolTxs :: !(Set txid) -- ^ TXs on their way to the mempool. Used to prevent issueing new -- fetch requests for them. } @@ -258,10 +258,12 @@ pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, stInflight -- remove `tx`s which were already downloaded by some -- other peer or are in-flight or unknown by this peer. - `Map.withoutKeys` - (Map.keysSet bufferedTxs <> requestedTxsInflight <> unknownTxs - <> stInSubmissionToMempoolTxs) - + `Map.withoutKeys` ( + Map.keysSet bufferedTxs + <> requestedTxsInflight + <> unknownTxs + <> stInSubmissionToMempoolTxs + ) ) requestedTxsInflightSize -- pick from `txid`'s which are available from that given diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs index f1f5a19f57c..2c03a6958f9 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Policy.hs @@ -8,6 +8,7 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.Policy , NumTxIdsToReq (..) ) where +import Control.DeepSeq import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..)) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) @@ -64,6 +65,9 @@ data TxDecisionPolicy = TxDecisionPolicy { } deriving Show +instance NFData TxDecisionPolicy where + rnf TxDecisionPolicy{} = () + defaultTxDecisionPolicy :: TxDecisionPolicy defaultTxDecisionPolicy = TxDecisionPolicy { diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs index 32931ceccc2..0d9ffe4a506 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/State.hs @@ -186,14 +186,18 @@ splitAcknowledgedTxIds (txIdsToRequest, acknowledgedTxIds', unacknowledgedTxIds') where (acknowledgedTxIds', unacknowledgedTxIds') - = StrictSeq.spanl (\txid -> (txid `Map.member` bufferedTxs - || txid `Set.member` unknownTxs - || txid `Map.member` downloadedTxs) - && txid `Set.notMember` requestedTxsInflight + = StrictSeq.spanl (\txid -> + txid `Set.notMember` requestedTxsInflight + && ( + txid `Map.member` downloadedTxs + || txid `Set.member` unknownTxs + || txid `Map.member` bufferedTxs + ) ) unacknowledgedTxIds - numOfUnacked = StrictSeq.length unacknowledgedTxIds - numOfAcked = StrictSeq.length acknowledgedTxIds' + + numOfUnacked = StrictSeq.length unacknowledgedTxIds + numOfAcked = StrictSeq.length acknowledgedTxIds' unackedAndRequested = fromIntegral numOfUnacked + requestedTxIdsInflight txIdsToRequest = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs index 950cd18f757..cddd83a3a5c 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/V2/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} @@ -35,6 +36,7 @@ module Ouroboros.Network.TxSubmission.Inbound.V2.Types , TxSubmissionProtocolError (..) ) where +import Control.DeepSeq import Control.Exception (Exception (..)) import Control.Monad.Class.MonadTime.SI import Data.Map.Strict (Map) @@ -132,7 +134,7 @@ data PeerTxState txid tx = PeerTxState { toMempoolTxs :: !(Map txid tx) } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance ( NoThunks txid , NoThunks tx @@ -242,7 +244,7 @@ data SharedTxState peeraddr txid tx = SharedTxState { -- | Rng used to randomly order peers peerRng :: !StdGen } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance ( NoThunks peeraddr , NoThunks tx @@ -256,7 +258,7 @@ instance ( NoThunks peeraddr -- newtype TxsToMempool txid tx = TxsToMempool { listOfTxsToMempool :: [(txid, tx)] } - deriving newtype (Eq, Show, Semigroup, Monoid) + deriving newtype (Eq, Show, Semigroup, Monoid, NFData) -- | Decision made by the decision logic. Each peer will receive a 'Decision'. @@ -290,6 +292,10 @@ data TxDecision txid tx = TxDecision { } deriving (Show, Eq) +instance (NFData txid, NFData tx) => NFData (TxDecision txid tx) where + -- all fields except `txdTxsToMempool` when evaluated to WHNF evaluate to NF. + rnf TxDecision {txdTxsToMempool} = rnf txdTxsToMempool + -- | A non-commutative semigroup instance. -- -- /note:/ this instance must be consistent with `pickTxsToDownload` and how diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index 522a59de869..297b9b02074 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -447,7 +447,7 @@ microbenchmark1GenerateInput verbose' n = do es <- generate (vector n) let fixedScript = mkFixedScript (Script (NonEmpty.fromList es)) when verbose' $ - mapM_ print (let FixedScript s = fixedScript in s) + mapM_ print (getFixedScript fixedScript) return fixedScript -- TODO: diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs index 9ef76318915..ed3e1fae1b1 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -19,6 +19,8 @@ module Test.Ouroboros.Network.TxSubmission.TxLogic , PeerAddr , sharedTxStateInvariant , InvariantStrength (..) + -- * Utils + , mkDecisionContext ) where import Prelude hiding (seq) @@ -39,6 +41,7 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.Typeable import System.Random (StdGen, mkStdGen) +import System.Random.SplitMix (SMGen) import NoThunks.Class @@ -55,6 +58,8 @@ import Test.Ouroboros.Network.TxSubmission.Types import Test.QuickCheck import Test.QuickCheck.Function (apply) +import Test.QuickCheck.Gen (Gen (..)) +import Test.QuickCheck.Random (QCGen (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Text.Pretty.Simple @@ -1224,6 +1229,25 @@ instance (Arbitrary txid, Ord txid, Function txid, CoArbitrary txid) ] +-- | Construct decision context in a deterministic way. For micro benchmarks. +-- +-- It is based on QuickCheck's `arbitrary` instance for `ArbDecisionContexts. +-- +mkDecisionContext :: SMGen + -- ^ pseudo random generator + -> Int + -- ^ size + -> (TxDecisionPolicy, SharedTxState PeerAddr TxId (Tx TxId)) +mkDecisionContext stdgen size = + case unGen gen (QCGen stdgen) size of + ArbDecisionContexts { arbDecisionPolicy = policy, + arbSharedState = sharedState + } -> (policy, sharedState) + where + gen :: Gen (ArbDecisionContexts TxId) + gen = arbitrary + + prop_ArbDecisionContexts_generator :: ArbDecisionContexts TxId -> Property diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs index fe083563843..65daed935d0 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -31,6 +32,7 @@ import Prelude hiding (seq) import NoThunks.Class import Control.Concurrent.Class.MonadSTM +import Control.DeepSeq import Control.Exception (SomeException (..)) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork @@ -72,7 +74,7 @@ data Tx txid = Tx { -- invalid tx's in this sense. getTxValid :: !Bool } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, NFData) instance NoThunks txid => NoThunks (Tx txid) instance ShowProxy txid => ShowProxy (Tx txid) where