Add Mempool benchmarks

Change-Id: Id0000000f877bff9ab7888eed3c229decd1bbb61

bench/Bench.hs

@@ -12,6 +12,7 @@ import Criterion.Main
 
 import qualified Chainweb.Pact.Backend.Bench as Checkpointer
 import qualified Chainweb.Pact.Backend.ForkingBench as ForkingBench
+import qualified Chainweb.MempoolBench as MempoolBench
 import qualified JSONEncoding
 
 import Chainweb.Storage.Table.RocksDB
@@ -27,4 +28,5 @@ main = withTempRocksDb "benchmarks" $ \rdb -> do
     [ Checkpointer.bench
     , ForkingBench.bench rdb
     , JSONEncoding.benchmarks
+    , MempoolBench.bench
     ]

bench/Chainweb/MempoolBench.hs

@@ -0,0 +1,170 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+module Chainweb.MempoolBench (bench) where
+
+-- import Control.Concurrent
+import Control.Lens
+import Control.Monad
+-- import Control.Monad.Except
+-- import Data.Function ((&))
+import Data.Vector qualified as V
+
+import Criterion.Main qualified as C
+import PropertyMatchers qualified as P
+import PropertyMatchers ((?))
+
+import Chainweb.BlockHash
+import Chainweb.BlockHeight
+import Chainweb.Graph (singletonChainGraph)
+import Chainweb.Mempool.Mempool qualified as Mempool
+import Chainweb.Mempool.InMem qualified as InMem
+import Chainweb.Mempool.InMemTypes qualified as InMem
+-- import Chainweb.Pact.PactService.Pact5.ExecBlock qualified as Pact5
+import Chainweb.Pact4.Transaction
+import Chainweb.Test.Pact4.Utils
+import Chainweb.Test.TestVersions
+import Chainweb.Utils
+import Chainweb.Utils.Bench
+import Chainweb.Version
+import Pact.Types.ChainMeta (getCurrentCreationTime)
+import Pact.Types.Command
+import System.IO.Unsafe (unsafePerformIO)
+import qualified Data.Set as S
+import Data.IORef
+
+
+-- pact5Validate logger v cid dbEnv bhi _bha txs =
+--     forM txs $
+--         runExceptT . Pact5.validateRawChainwebTx logger v cid dbEnv (_blockInProgressHandle blockInProgress) (ParentCreationTime parentTime) bhi isGenesis
+
+txCfg :: Mempool.TransactionConfig UnparsedTransaction
+txCfg = Mempool.pact4TransactionConfig
+
+inmemCfg :: InMem.InMemConfig UnparsedTransaction
+inmemCfg = InMem.InMemConfig
+    { InMem._inmemTxCfg = txCfg
+    , InMem._inmemTxBlockSizeLimit = Mempool.GasLimit 150_000
+    , InMem._inmemTxMinGasPrice = Mempool.GasPrice (0.0000000001)
+    , InMem._inmemMaxRecentItems = 2048
+    , InMem._inmemPreInsertPureChecks = return
+    , InMem._inmemPreInsertBatchChecks = return . fmap return
+    , InMem._inmemCurrentTxsSize = 1024 * 1024
+    }
+
+v :: ChainwebVersion
+v = instantCpmTestVersion singletonChainGraph
+
+setup :: V.Vector UnparsedTransaction -> IO (NoopNFData (Mempool.MempoolBackend UnparsedTransaction))
+setup txs = do
+    mp <- InMem.startInMemoryMempoolTest inmemCfg
+    Mempool.mempoolInsert mp Mempool.UncheckedInsert txs
+    return (NoopNFData mp)
+
+cmds :: V.Vector UnparsedTransaction
+cmds = unsafePerformIO $ V.generateM 4096 $ \i -> do
+    now <- getCurrentCreationTime
+    fmap unparseTransaction
+        $ buildCwCmd (sshow i) v
+        $ set cbCreationTime now
+        $ set cbGasLimit (Mempool.GasLimit 1)
+        $ defaultCmd
+
+txHash :: UnparsedTransaction -> Mempool.TransactionHash
+txHash = Mempool.txHasher txCfg
+
+cmdHashes :: S.Set Mempool.TransactionHash
+cmdHashes = S.fromList (txHash <$> V.toList cmds)
+
+expiredCmds :: V.Vector UnparsedTransaction
+expiredCmds = unsafePerformIO $ V.generateM 4096 $ \i -> do
+    fmap unparseTransaction
+        $ buildCwCmd (sshow i) v
+        $ set cbGasLimit (Mempool.GasLimit 1)
+        $ defaultCmd
+
+setupMakeTxs :: V.Vector UnparsedTransaction -> IO (NoopNFData (Mempool.MempoolBackend UnparsedTransaction, V.Vector UnparsedTransaction))
+setupMakeTxs txs = do
+    mp <- InMem.startInMemoryMempoolTest inmemCfg
+    return $ NoopNFData (mp, txs)
+
+bfEmpty :: Mempool.BlockFill
+bfEmpty = Mempool.BlockFill
+    { Mempool._bfGasLimit = Mempool.GasLimit 150_000
+        -- ^ Fetch pending transactions up to this limit.
+    , Mempool._bfTxHashes = mempty
+        -- ^ Fetch only transactions not in set.
+    , Mempool._bfCount = 0
+    }
+
+bfWithNHashes :: Int -> Mempool.BlockFill
+bfWithNHashes n = bfEmpty
+    { Mempool._bfTxHashes = S.take n cmdHashes
+    }
+
+mempoolGetBlockBench :: _ => _
+mempoolGetBlockBench name p bf n = C.bench name
+    $ C.perRunEnv (setup (V.take n cmds)) $ \(NoopNFData mp) -> do
+    Mempool.mempoolGetBlock mp bf Mempool.noopMempoolPreBlockCheck (BlockHeight 1) nullBlockHash
+        >>= p
+
+allPendingTxHashes :: Mempool.MempoolBackend t -> IO [Mempool.TransactionHash]
+allPendingTxHashes mp = do
+    allRef <- newIORef []
+    void $ Mempool.mempoolGetPendingTransactions mp Nothing (\pending -> modifyIORef' allRef (pending :))
+    concatMap V.toList <$> readIORef allRef
+
+bench :: C.Benchmark
+bench = C.bgroup "mempool" $ concat
+    [
+        [ mempoolGetBlockBench
+            ("mempoolGetBlock " <> show n)
+            (P.fun V.length ? P.equals n) bfEmpty n
+        | n <- [1,16,64,256,1024,4096]
+        ],
+        [ mempoolGetBlockBench
+            ("mempoolGetBlockHalfExcludedHashes " <> show n)
+            (P.fun V.length ? P.lte n) (bfWithNHashes (n `div` 2)) n
+        | n <- [1,16,64,256,1024,4096]
+        ],
+        [ C.bench "mempoolInsertChecked" $ C.perRunEnvWithCleanup
+            (setupMakeTxs (V.take 2000 cmds))
+            (\(NoopNFData (mp, _)) ->
+                allPendingTxHashes mp >>= P.fun length ? P.equals 2000
+            )
+            $ \(NoopNFData ~(mp, txs)) -> do
+                Mempool.mempoolInsert mp Mempool.CheckedInsert txs
+        , C.bench "mempoolInsert" $ C.perRunEnvWithCleanup
+            (setupMakeTxs (V.take 2000 cmds))
+            (\(NoopNFData (mp, _)) ->
+                allPendingTxHashes mp >>= P.fun length ? P.equals 2000
+            )
+            $ \(NoopNFData ~(mp, txs)) -> do
+                Mempool.mempoolInsert mp Mempool.UncheckedInsert txs
+        , C.bench "mempoolAddToBadList" $ C.perRunEnvWithCleanup
+            (setupMakeTxs (V.take 2000 cmds))
+            (\(NoopNFData (mp, _)) ->
+                Mempool.mempoolCheckBadList mp (txHash <$> V.take 2000 cmds)
+                    >>= P.alignExact (V.replicate 2000 (P.equals True))
+            )
+            $ \(NoopNFData ~(mp, txs)) -> do
+                Mempool.mempoolAddToBadList mp (Mempool.pact4RequestKeyToTransactionHash . cmdToRequestKey <$> txs)
+        , C.bench "mempoolPrune" $ C.perRunEnvWithCleanup
+            (setup (V.take 2000 cmds))
+            (\(NoopNFData mp) ->
+                allPendingTxHashes mp >>= P.fun length ? P.equals 2000)
+            $ \(NoopNFData mp) -> do
+                Mempool.mempoolPrune mp
+        , C.bench "mempoolPruneExpired" $ C.perRunEnvWithCleanup
+            (setup (V.take 2000 expiredCmds))
+            (\(NoopNFData mp) ->
+                allPendingTxHashes mp >>= P.equals [])
+            $ \(NoopNFData mp) -> do
+                Mempool.mempoolPrune mp
+        ]
+    ]
+
+    -- TODO: benchmark what happens when we have a bunch of txs that are too big for the gas limit,
+    -- interleaved with txs that are smaller, in gas price order

chainweb.cabal

@@ -864,6 +864,7 @@ benchmark bench
     main-is: Bench.hs
     type: exitcode-stdio-1.0
     other-modules:
+        Chainweb.MempoolBench
         Chainweb.Pact.Backend.Bench
         Chainweb.Pact.Backend.ForkingBench
         Chainweb.Utils.Bench
@@ -896,3 +897,4 @@ benchmark bench
         , text >= 2.0
         , vector >= 0.12.2
         , yaml >= 0.11
+        , property-matchers ^>= 0.4