From ab3605279fcff7591131b22f2ecd7a0699ae025d Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Sat, 18 Jan 2025 10:37:20 -0500 Subject: [PATCH] Add Mempool benchmarks Change-Id: Id0000000f877bff9ab7888eed3c229decd1bbb61 --- bench/Bench.hs | 2 + bench/Chainweb/MempoolBench.hs | 170 +++++++++++++++++++++++++++++++++ chainweb.cabal | 2 + 3 files changed, 174 insertions(+) create mode 100644 bench/Chainweb/MempoolBench.hs diff --git a/bench/Bench.hs b/bench/Bench.hs index d90af9e571..c46b122078 100644 --- a/bench/Bench.hs +++ b/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 ] diff --git a/bench/Chainweb/MempoolBench.hs b/bench/Chainweb/MempoolBench.hs new file mode 100644 index 0000000000..da12708025 --- /dev/null +++ b/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 diff --git a/chainweb.cabal b/chainweb.cabal index 516b413c46..f5ee2e180e 100644 --- a/chainweb.cabal +++ b/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