microbenchmarks of makeDecisions

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,

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 :| [])

ouroboros-network/bench/Main.hs

@@ -2,23 +2,73 @@
 
 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)
 
 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
+          ]
+        , 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
+                )
+-}
+          ]
+        ]
       ]
-  where
-    benchmarks = [("1k"  ,   1000)
-                 ,("10k" , 10_000)
-                 ,("100k",100_000)
-                 ]

ouroboros-network/ouroboros-network.cabal

@@ -345,6 +345,7 @@ library testlib
     psqueues,
     random,
     serialise,
+    splitmix,
     tasty,
     tasty-hunit,
     tasty-quickcheck,
@@ -506,18 +507,21 @@ 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
+  -- 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

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

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 {

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 =

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

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'
 --
@@ -443,12 +447,15 @@ 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:
+-- * 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 =

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