wip benching

Change-Id: Ic7ad4dd33a4df801c2c8e8853ab5e45b08b51db8

bench/Bench.hs

@@ -10,10 +10,10 @@
 -- Stability: experimental
 module Main (main) where
 
+import Chainweb.MempoolBench qualified as MempoolBench
 import Chainweb.Pact.Backend.ApplyCmd qualified as ApplyCmd
 import Chainweb.Pact.Backend.Bench qualified as Checkpointer
 import Chainweb.Pact.Backend.ForkingBench qualified as ForkingBench
-import Chainweb.MempoolBench qualified as MempoolBench
 import Chainweb.Pact.Backend.PactService qualified as PactService
 import Chainweb.Storage.Table.RocksDB (withTempRocksDb)
 import Chainweb.Version.Development (pattern Development)

bench/Chainweb/Pact/Backend/ApplyCmd.hs

@@ -7,7 +7,10 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
+<<<<<<< HEAD
 {-# LANGUAGE OverloadedRecordDot #-}
+=======
+>>>>>>> 5675d1977 (wip benching)
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE QuantifiedConstraints #-}

bench/Chainweb/Pact/Backend/ForkingBench.hs

@@ -351,6 +351,7 @@ cid = someChainId testVer
 
 testVer :: ChainwebVersion
 testVer = slowForkingCpmTestVersion petersonChainGraph
+--testVer = pact5SlowCpmTestVersion petersonChainGraph
 
 -- MORE CODE DUPLICATION
 
@@ -367,7 +368,7 @@ createCoinAccount v meta name = do
     res <- mkExec (T.pack theCode) theData meta (NEL.toList $ attach sender00Keyset) [] (Just $ Pact.NetworkId $ toText (_versionName v)) Nothing
     pure (nameKeyset, res)
   where
-    theCode = printf "(coin.transfer-create \"sender00\" \"%s\" (read-keyset \"%s\") 1000.0)" name name
+    theCode = "1" --printf "(coin.transfer-create \"sender00\" \"%s\" (read-keyset \"%s\") 1000.0)" name name
     isSenderAccount name' =
       elem name' (map getAccount coinAccountNames)
 

cabal.project.freeze

@@ -1,6 +1,6 @@
 active-repositories: hackage.haskell.org:merge
-constraints: any.Cabal ==3.12.1.0,
-             any.Cabal-syntax ==3.12.1.0,
+constraints: any.Cabal ==3.10.2.0,
+             any.Cabal-syntax ==3.10.2.0,
              any.Decimal ==0.5.2,
              any.Diff ==1.0.2,
              any.Glob ==0.10.2,
@@ -401,4 +401,4 @@ constraints: any.Cabal ==3.12.1.0,
              any.zigzag ==0.1.0.0,
              any.zip-archive ==0.4.3.2,
              any.zlib ==0.7.1.0
-index-state: hackage.haskell.org 2025-01-24T21:23:54Z
+index-state: hackage.haskell.org 2025-01-31T18:30:19Z

chainweb.cabal

@@ -881,6 +881,16 @@ benchmark bench
         , aeson >= 2.2
         , async >= 2.2
         , base >= 4.12 && < 5
+        , resourcet
+        , unordered-containers
+        , direct-sqlite
+        , pact-tng
+        , pact-tng:pact-request-api
+        , pact-json
+        , safe-exceptions
+        , tasty
+        , tasty-hunit
+        , property-matchers
         , bytestring >= 0.10.12
         , chainweb-storage >= 0.1
         , containers >= 0.5

default.nix

@@ -81,6 +81,9 @@ let haskellSrc = with nix-filter.lib; filter {
       modules = [
         {
           packages.http2.doHaddock = false;
+          #enableProfiling = true;
+          #enableLibraryProfiling = true;
+          #profilingDetail = "late";
         }
       ];
     };

libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs

@@ -89,6 +89,7 @@ module Chainweb.Storage.Table.RocksDB
   ) where
 
 import Control.Exception(evaluate)
+import Control.DeepSeq
 import Control.Lens
 import Control.Monad
 import Control.Monad.Catch
@@ -299,6 +300,9 @@ data Codec a = Codec
         -- ^ decode a value. Throws an exception of decoding fails.
     }
 
+instance NFData (Codec a) where
+    rnf !_ = ()
+
 instance NoThunks (Codec a) where
     -- NoThunks does not look inside of closures for captured thunks
     wNoThunks _ _ = return Nothing

src/Chainweb/BlockHeaderDB/Internal.hs

@@ -381,4 +381,3 @@ insertBlockHeaderDb db = dbAddChecked db . _validatedHeader
 unsafeInsertBlockHeaderDb :: BlockHeaderDb -> BlockHeader -> IO ()
 unsafeInsertBlockHeaderDb = dbAddChecked
 {-# INLINE unsafeInsertBlockHeaderDb #-}
-

src/Chainweb/CutDB.hs

@@ -767,6 +767,7 @@ cutHashesToBlockHeaderMap
         -- ^ The 'Left' value holds missing hashes, the 'Right' value holds
         -- a 'Cut'.
 cutHashesToBlockHeaderMap conf logfun headerStore payloadStore hs =
+    withEvent "FETCH CUT" $
     trace logfun "Chainweb.CutDB.cutHashesToBlockHeaderMap" hsid 1 $ do
         timeout (_cutDbParamsFetchTimeout conf) go >>= \case
             Nothing -> do

src/Chainweb/Logger.hs

@@ -34,6 +34,7 @@ module Chainweb.Logger
 , genericLogger
 ) where
 
+import Control.DeepSeq
 import Control.Lens
 import qualified Data.Text as T
 import Data.Time
@@ -111,6 +112,9 @@ data GenericLogger = GenericLogger
 
 makeLenses 'GenericLogger
 
+instance NFData GenericLogger where
+    rnf (GenericLogger a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
+
 instance L.LoggerCtx GenericLogger SomeLogMessage where
     loggerFunIO ctx level msg
         | level <= l2l (_glLevel ctx) = do

src/Chainweb/Mempool/InMem.hs

@@ -84,6 +84,7 @@ import Numeric.AffineSpace
 import Data.ByteString (ByteString)
 import Data.Either (partitionEithers)
 import Control.Lens
+import Utils.Logging.Trace (withEvent)
 
 ------------------------------------------------------------------------------
 compareOnGasPrice :: TransactionConfig t -> t -> t -> Ordering
@@ -496,23 +497,27 @@ txTTLCheck txcfg now t = do
 -- the latter case.
 --
 insertCheckInMem'
-    :: forall t
-    .  NFData t
-    => InMemConfig t    -- ^ in-memory config
+    :: forall t logger. (NFData t, Logger logger)
+    => logger
+    -> InMemConfig t    -- ^ in-memory config
     -> MVar (InMemoryMempoolData t)  -- ^ in-memory state
     -> Vector t  -- ^ new transactions
     -> IO (Vector (T2 TransactionHash t))
-insertCheckInMem' cfg lock txs
+insertCheckInMem' logger cfg lock txs
   | V.null txs = pure V.empty
   | otherwise = do
     now <- getCurrentTimeIntegral
     badmap <- withMVarMasked lock $ readIORef . _inmemBadMap
     curTxIdx <- withMVarMasked lock $ readIORef . _inmemCurrentTxs
 
-    let withHashes :: Vector (T2 TransactionHash t)
-        withHashes = flip V.mapMaybe txs $ \tx ->
-          let !h = hasher tx
-          in (T2 h) <$> hush (validateOne cfg badmap curTxIdx now tx h)
+    withHashes :: Vector (T2 TransactionHash t) <- fmap V.catMaybes $ do
+      flip V.mapM txs $ \tx -> do
+        let !h = hasher tx
+        let validationResult = validateOne cfg badmap curTxIdx now tx h
+        case validationResult of
+          Left err -> logFunctionText logger Debug $ "insertCheckInMem' (CheckedInsert validateOne): " <> sshow err
+          Right _ -> pure ()
+        pure (T2 h <$> hush validationResult)
 
     V.mapMaybe hush <$!> _inmemPreInsertBatchChecks cfg withHashes
   where
@@ -544,7 +549,7 @@ insertInMem logger cfg lock runCheck txs0 = do
   where
     insertCheck :: IO (Vector (T2 TransactionHash t))
     insertCheck = case runCheck of
-      CheckedInsert -> insertCheckInMem' cfg lock txs0
+      CheckedInsert -> insertCheckInMem' logger cfg lock txs0
       UncheckedInsert -> return $! V.map (\tx -> T2 (hasher tx) tx) txs0
 
     txcfg = _inmemTxCfg cfg
@@ -575,7 +580,7 @@ getBlockInMem
     -> IO (Vector to)
 getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight phash = do
     logFunctionText logg Debug $ "getBlockInMem: " <> sshow (gasLimit,bheight,phash)
-    withMVar lock $ \mdata -> do
+    withMVar lock $ \mdata -> withEvent "getBlockInMem" $ do
         now <- getCurrentTimeIntegral
 
         pendingDataBeforePrune <- readIORef (_inmemPending mdata)
@@ -604,7 +609,7 @@ getBlockInMem logg cfg lock (BlockFill gasLimit txHashes _) txValidate bheight p
         writeIORef (_inmemPending mdata) $! force psq''
         writeIORef (_inmemBadMap mdata) $! force badmap'
         mout <- V.thaw $ V.map (\(_, (_, t, tOut)) -> (t, tOut)) out
-        TimSort.sortBy (compareOnGasPrice txcfg `on` fst) mout
+        withEvent "Tim Sorton" $ TimSort.sortBy (compareOnGasPrice txcfg `on` fst) mout
         fmap snd <$> V.unsafeFreeze mout
 
   where

src/Chainweb/Pact/PactService.hs

@@ -148,8 +148,7 @@ import qualified Data.List.NonEmpty as NonEmpty
 
 
 runPactService
-    :: Logger logger
-    => CanReadablePayloadCas tbl
+    :: (Logger logger, CanReadablePayloadCas tbl)
     => ChainwebVersion
     -> ChainId
     -> logger
@@ -199,7 +198,7 @@ withPactService ver cid chainwebLogger txFailuresCounter bhDb pdb sqlenv config
                     , _psTxFailuresCounter = txFailuresCounter
                     , _psTxTimeLimit = _pactTxTimeLimit config
                     }
-            !pst = PactServiceState mempty
+        let !pst = PactServiceState mempty
 
         runPactServiceM pst pse $ do
             when (_pactFullHistoryRequired config) $ do
@@ -330,65 +329,68 @@ serviceRequests memPoolAccess reqQ = go
           logFn :: LogFunction
           logFn = logFunction $ addLabel ("pact-request-id", requestId) _psLogger
         logDebugPact $ "serviceRequests: " <> sshow msg
-        case msg of
-            CloseMsg ->
+        let eventName = "PACT " <> pactReqType msg
+        keepGoing <- withEvent eventName $ case msg of
+            CloseMsg -> do
                 tryOne "execClose" statusRef $ return ()
+                return False
             LocalMsg (LocalReq localRequest preflight sigVerify rewindDepth) -> do
                 trace logFn "Chainweb.Pact.PactService.execLocal" () 0 $
                     tryOne "execLocal" statusRef $
                         execLocal localRequest preflight sigVerify rewindDepth
-                go
+                return True
             NewBlockMsg NewBlockReq {..} -> do
                 trace logFn "Chainweb.Pact.PactService.execNewBlock"
                     () 1 $
                     tryOne "execNewBlock" statusRef $
                         execNewBlock memPoolAccess _newBlockMiner _newBlockFill _newBlockParent
-                go
+                return True
             ContinueBlockMsg (ContinueBlockReq bip) -> do
                 trace logFn "Chainweb.Pact.PactService.execContinueBlock"
                     () 1 $
                     tryOne "execContinueBlock" statusRef $
                         execContinueBlock memPoolAccess bip
-                go
+                return True
             ValidateBlockMsg ValidateBlockReq {..} -> do
                 tryOne "execValidateBlock" statusRef $
                     fmap fst $ trace' logFn "Chainweb.Pact.PactService.execValidateBlock"
                         (\_ -> _valBlockHeader)
                         (\(_, g) -> fromIntegral g)
                         (execValidateBlock memPoolAccess _valBlockHeader _valCheckablePayload)
-                go
+                return True
             LookupPactTxsMsg (LookupPactTxsReq confDepth txHashes) -> do
                 trace logFn "Chainweb.Pact.PactService.execLookupPactTxs" ()
                     (length txHashes) $
                     tryOne "execLookupPactTxs" statusRef $
                         execLookupPactTxs confDepth txHashes
-                go
+                return True
             PreInsertCheckMsg (PreInsertCheckReq txs) -> do
                 trace logFn "Chainweb.Pact.PactService.execPreInsertCheckReq" ()
                     (length txs) $
                     tryOne "execPreInsertCheckReq" statusRef $
                         execPreInsertCheckReq txs
-                go
+                return True
             BlockTxHistoryMsg (BlockTxHistoryReq bh d) -> do
                 trace logFn "Chainweb.Pact.PactService.execBlockTxHistory" bh 1 $
                     tryOne "execBlockTxHistory" statusRef $
                         execBlockTxHistory bh d
-                go
+                return True
             HistoricalLookupMsg (HistoricalLookupReq bh d k) -> do
                 trace logFn "Chainweb.Pact.PactService.execHistoricalLookup" bh 1 $
                     tryOne "execHistoricalLookup" statusRef $
                         execHistoricalLookup bh d k
-                go
+                return True
             SyncToBlockMsg SyncToBlockReq {..} -> do
                 trace logFn "Chainweb.Pact.PactService.execSyncToBlock" _syncToBlockHeader 1 $
                     tryOne "syncToBlockBlock" statusRef $
                         execSyncToBlock _syncToBlockHeader
-                go
+                return True
             ReadOnlyReplayMsg ReadOnlyReplayReq {..} -> do
                 trace logFn "Chainweb.Pact.PactService.execReadOnlyReplay" (_readOnlyReplayLowerBound, _readOnlyReplayUpperBound) 1 $
                     tryOne "readOnlyReplayBlock" statusRef $
                         execReadOnlyReplay _readOnlyReplayLowerBound _readOnlyReplayUpperBound
-                go
+                return True
+        when keepGoing go
 
     tryOne
         :: forall a. Text

src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs

@@ -108,6 +108,7 @@ import Chainweb.Pact4.ModuleCache
 import Control.Monad.Except
 import qualified Data.List.NonEmpty as NE
 import Chainweb.Pact.Backend.Types (BlockHandle(..))
+import Utils.Logging.Trace
 
 
 -- | Execute a block -- only called in validate either for replay or for validating current block.
@@ -412,7 +413,7 @@ runCoinbase
     -> CoinbaseUsePrecompiled
     -> ModuleCache
     -> PactBlockM logger tbl (Pact4.CommandResult [Pact4.TxLogJson])
-runCoinbase miner enfCBFail usePrecomp mc = do
+runCoinbase miner enfCBFail usePrecomp mc = withEvent "runCoinbase" $ do
     isGenesis <- view psIsGenesis
     if isGenesis
     then return noCoinbase
@@ -454,7 +455,7 @@ applyPactCmds
     -> Maybe Pact4.Gas
     -> Maybe Micros
     -> PactBlockM logger tbl (T2 (Vector (Either CommandInvalidError (Pact4.CommandResult [Pact4.TxLogJson]))) ModuleCache)
-applyPactCmds cmds miner startModuleCache blockGas txTimeLimit = do
+applyPactCmds cmds miner startModuleCache blockGas txTimeLimit = withEvent "applyPactCmds" $ do
     let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to Pact4._crGas) txs
     (txOuts, T2 mcOut _) <- tracePactBlockM' "applyPactCmds" (\_ -> ()) (txsGas . fst) $
       flip runStateT (T2 startModuleCache blockGas) $
@@ -709,7 +710,7 @@ continueBlock mpAccess blockInProgress = do
     T2
       finalModuleCache
       BlockFill { _bfTxHashes = requestKeys, _bfGasLimit = finalGasLimit }
-      <- refill fetchLimit txTimeLimit successes failures initCache initState
+      <- withEvent "refill" $ refill fetchLimit txTimeLimit successes failures initCache initState
 
     liftPactServiceM $ logInfoPact $ "(request keys = " <> sshow requestKeys <> ")"
 
@@ -751,7 +752,7 @@ continueBlock mpAccess blockInProgress = do
 
 
     getBlockTxs :: BlockFill -> PactBlockM logger tbl (Vector Pact4.Transaction)
-    getBlockTxs bfState = do
+    getBlockTxs bfState = withEvent "getBlockTxs" $ do
       dbEnv <- view psBlockDbEnv
       psEnv <- ask
       let v = _chainwebVersion psEnv

src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs

@@ -213,7 +213,7 @@ continueBlock mpAccess blockInProgress = do
 
   where
   maybeBlockParentHeader = _parentHeader <$> _blockInProgressParentHeader blockInProgress
-  refill fetchLimit txTimeLimit blockFillState = over _2 reverse <$> go [] [] blockFillState
+  refill fetchLimit txTimeLimit blockFillState = withEvent "refill" $ over _2 reverse <$> go [] [] blockFillState
     where
     go
       :: [CompletedTransactions]
@@ -322,7 +322,7 @@ continueBlock mpAccess blockInProgress = do
         return (completedTxs, Pact5.RequestKey <$> invalidTxHashes, p4FinalRemainingGas, timedOut)
 
   getBlockTxs :: BlockFill -> PactBlockM logger tbl (Vector Pact5.Transaction)
-  getBlockTxs blockFillState = do
+  getBlockTxs blockFillState = withEvent "getBlockTxs" $ do
     liftPactServiceM $ logDebugPact "Refill: fetching transactions"
     v <- view chainwebVersion
     cid <- view chainId

src/Chainweb/Pact/Types.hs

@@ -102,6 +102,7 @@ module Chainweb.Pact.Types
   , LocalPreflightSimulation(..)
   , SyncToBlockReq(..)
   , RequestMsg(..)
+  , pactReqType
   , RewindLimit(..)
   , LookupPactTxsReq(..)
   , BlockTxHistoryReq(..)
@@ -1017,6 +1018,20 @@ data RequestMsg r where
     ReadOnlyReplayMsg :: !ReadOnlyReplayReq -> RequestMsg ()
     CloseMsg :: RequestMsg ()
 
+pactReqType :: RequestMsg r -> String
+pactReqType = \case
+    ContinueBlockMsg {} -> "ContinueBlock"
+    NewBlockMsg {} -> "NewBlock"
+    ValidateBlockMsg {} -> "ValidateBlock"
+    LocalMsg {} -> "Local"
+    LookupPactTxsMsg {} -> "LookupPactTxs"
+    PreInsertCheckMsg {} -> "PreInsertCheck"
+    BlockTxHistoryMsg {} -> "BlockTxHistory"
+    HistoricalLookupMsg {} -> "HistoricalLookup"
+    SyncToBlockMsg {} -> "SyncToBlock"
+    ReadOnlyReplayMsg {} -> "ReadOnlyReplay"
+    CloseMsg {} -> "Close"
+
 instance Show (RequestMsg r) where
     show (NewBlockMsg req) = show req
     show (ContinueBlockMsg req) = show req