WIP

IntersectMBO · May 9, 2024 · 984aab3 · 984aab3
1 parent 7bed57f
commit 984aab3
Show file tree

Hide file tree

Showing 2 changed files with 19 additions and 16 deletions.
diff --git a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs
@@ -28,7 +28,6 @@ import           Control.Monad.Trans.Except (except)
 import           Data.Set (Set, (\\))
 import qualified Data.Set as Set
 import           Data.TreeDiff (ToExpr)
-import           Data.Word (Word8)
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
 import qualified Ouroboros.Consensus.Block as Block
@@ -56,7 +55,7 @@ data Tx = Tx {
   deriving stock (Eq, Ord, Generic, Show)
   deriving anyclass (NoThunks, NFData)
 
-newtype Token = Token { unToken :: Word8  }
+newtype Token = Token { unToken :: Int  }
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NoThunks, ToExpr, Serialise, NFData)
 
@@ -81,7 +80,7 @@ sampleLedgerConfig = testBlockLedgerConfigFrom $
 -------------------------------------------------------------------------------}
 
 data TestLedgerState = TestLedgerState {
-    availableTokens :: Set Token
+    availableTokens :: !(Set Token)
   }
   deriving stock (Generic, Eq, Show)
   deriving anyclass (NoThunks, ToExpr, Serialise)

diff --git a/ouroboros-consensus/bench/mempool-bench/Main.hs b/ouroboros-consensus/bench/mempool-bench/Main.hs
@@ -11,7 +11,8 @@ import           Bench.Consensus.Mempool
 import           Bench.Consensus.Mempool.TestBlock (TestBlock)
 import qualified Bench.Consensus.Mempool.TestBlock as TestBlock
 import           Control.Arrow (first)
-import           Control.Monad (unless, void)
+import           Control.DeepSeq
+import           Control.Monad (unless)
 import qualified Control.Tracer as Tracer
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BL
@@ -27,7 +28,7 @@ import qualified Test.Consensus.Mempool.Mocked as Mocked
 import           Test.Consensus.Mempool.Mocked (MockedMempool)
 import           Test.Tasty (withResource)
 import           Test.Tasty.Bench (CsvPath (CsvPath), bench, benchIngredients,
-                     bgroup, nfIO)
+                     bgroup, whnfIO)
 import           Test.Tasty.HUnit (testCase, (@?=))
 import           Test.Tasty.Options (changeOption)
 import           Test.Tasty.Runners (parseOptions, tryIngredients)
@@ -50,24 +51,27 @@ main = withStdTerminalHandles $ do
       where
         benchmarkJustAddingTransactions =
             bgroup "Just adding" $
-                fmap benchAddNTxs [10_000, 1_000_000]
+                fmap benchAddNTxs [10_000, 20_000]
           where
             benchAddNTxs n =
                 withResource
-                  (let txs = mkNTryAddTxs n in fmap (, txs) (openMempoolWithCapacityFor txs))
+                  (pure $!! force (mkNTryAddTxs n))
                   (\_ -> pure ())
-                  (\getAcquiredRes -> do
-                      let withAcquiredMempool act = do
-                            (mempool, txs) <- getAcquiredRes
-                            void $ act mempool txs
-                            -- TODO: consider adding a 'reset' command to the mempool to make sure its state is not tainted.
-                            Mocked.removeTxs mempool $ getCmdsTxIds txs
+                  (\getTxs -> do
                       bgroup (show n <> " transactions") [
-                          bench "benchmark" $ nfIO $ withAcquiredMempool $ \mempool txs -> do
+                          bench "setup mempool" $ whnfIO $ do
+                            txs <- getTxs
+                            openMempoolWithCapacityFor txs
+                        , bench "setup mempool + benchmark" $ whnfIO $ do
+                            txs <- getTxs
+                            mempool <- openMempoolWithCapacityFor txs
                             run mempool txs
-                        , testCase "test" $ withAcquiredMempool $ \mempool txs ->
+                        , testCase "test" $ do
+                            txs <- getTxs
+                            mempool <- openMempoolWithCapacityFor txs
                             testAddTxs mempool txs
-                        , testCase "txs length" $ withAcquiredMempool $ \_mempool txs -> do
+                        , testCase "txs length" $ do
+                            txs <- getTxs
                             length txs @?= n
                         ]
                   )