tx-submission: micro benchmark for makeDecisions

Author: coot

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
+                )
+-}
+          ]
         ]
       ]

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

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

@@ -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:

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

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