From 9160174b0cbe607fffe440783a15f75404f186da Mon Sep 17 00:00:00 2001 From: chessai Date: Fri, 17 Jan 2025 14:34:32 -0600 Subject: [PATCH] wip benching Change-Id: Ic7ad4dd33a4df801c2c8e8853ab5e45b08b51db8 --- bench/Bench.hs | 2 +- bench/Chainweb/Pact/Backend/ApplyCmd.hs | 3 + bench/Chainweb/Pact/Backend/ForkingBench.hs | 3 +- cabal.project.freeze | 6 +- chainweb.cabal | 10 ++++ default.nix | 3 + .../src/Chainweb/Storage/Table/RocksDB.hs | 4 ++ src/Chainweb/BlockHeaderDB/Internal.hs | 1 - src/Chainweb/CutDB.hs | 1 + src/Chainweb/Logger.hs | 4 ++ src/Chainweb/Mempool/InMem.hs | 27 +++++---- src/Chainweb/Pact/PactService.hs | 32 +++++----- .../Pact/PactService/Pact4/ExecBlock.hs | 9 +-- .../Pact/PactService/Pact5/ExecBlock.hs | 4 +- src/Chainweb/Pact/Types.hs | 15 +++++ src/Chainweb/Pact4/TransactionExec.hs | 15 +++-- src/Chainweb/Pact5/TransactionExec.hs | 23 ++++---- src/Chainweb/Sync/WebBlockHeaderStore.hs | 15 ++--- src/Utils/Logging/Trace.hs | 59 ++++++++++++++++++- test/lib/Chainweb/Test/Cut/TestBlockDb.hs | 5 ++ .../Test/Pact5/TransactionExecTest.hs | 2 +- 21 files changed, 177 insertions(+), 66 deletions(-) diff --git a/bench/Bench.hs b/bench/Bench.hs index 419e947445..022d37d261 100644 --- a/bench/Bench.hs +++ b/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) diff --git a/bench/Chainweb/Pact/Backend/ApplyCmd.hs b/bench/Chainweb/Pact/Backend/ApplyCmd.hs index d581f826bc..381bec8d74 100644 --- a/bench/Chainweb/Pact/Backend/ApplyCmd.hs +++ b/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 #-} diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index 35ca351250..2cf4e06d8d 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/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) diff --git a/cabal.project.freeze b/cabal.project.freeze index a1b35b2bcf..cc32d76012 100644 --- a/cabal.project.freeze +++ b/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 diff --git a/chainweb.cabal b/chainweb.cabal index f2ff3b0235..6dfe5743f7 100644 --- a/chainweb.cabal +++ b/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 diff --git a/default.nix b/default.nix index 45fd36d48b..b532ac08df 100644 --- a/default.nix +++ b/default.nix @@ -81,6 +81,9 @@ let haskellSrc = with nix-filter.lib; filter { modules = [ { packages.http2.doHaddock = false; + #enableProfiling = true; + #enableLibraryProfiling = true; + #profilingDetail = "late"; } ]; }; diff --git a/libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs b/libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs index 7cd49aca0d..dc783435cc 100644 --- a/libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs +++ b/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 diff --git a/src/Chainweb/BlockHeaderDB/Internal.hs b/src/Chainweb/BlockHeaderDB/Internal.hs index f272bb8b7a..c5abbc9a10 100644 --- a/src/Chainweb/BlockHeaderDB/Internal.hs +++ b/src/Chainweb/BlockHeaderDB/Internal.hs @@ -381,4 +381,3 @@ insertBlockHeaderDb db = dbAddChecked db . _validatedHeader unsafeInsertBlockHeaderDb :: BlockHeaderDb -> BlockHeader -> IO () unsafeInsertBlockHeaderDb = dbAddChecked {-# INLINE unsafeInsertBlockHeaderDb #-} - diff --git a/src/Chainweb/CutDB.hs b/src/Chainweb/CutDB.hs index ed982400d2..61a35ffb06 100644 --- a/src/Chainweb/CutDB.hs +++ b/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 diff --git a/src/Chainweb/Logger.hs b/src/Chainweb/Logger.hs index c1fab8d397..91fe978be7 100644 --- a/src/Chainweb/Logger.hs +++ b/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 diff --git a/src/Chainweb/Mempool/InMem.hs b/src/Chainweb/Mempool/InMem.hs index 2c86640c5b..924953ffe7 100644 --- a/src/Chainweb/Mempool/InMem.hs +++ b/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 diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 443ec5ad7a..8b625ffcdb 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/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 diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index b7e92d4487..f8da48e40f 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/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 diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 5154c08d7f..da080e8376 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/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 diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index c7c4d4e589..a25a4b46f6 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/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 diff --git a/src/Chainweb/Pact4/TransactionExec.hs b/src/Chainweb/Pact4/TransactionExec.hs index b877b1201b..65cf144b4b 100644 --- a/src/Chainweb/Pact4/TransactionExec.hs +++ b/src/Chainweb/Pact4/TransactionExec.hs @@ -163,6 +163,7 @@ import Chainweb.Pact4.ModuleCache import Chainweb.Pact4.Backend.ChainwebPactDb import Pact.Core.Errors (VerifierError(..)) +import Utils.Logging.Trace -- Note [Throw out verifier proofs eagerly] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -269,8 +270,6 @@ execTransactionM tenv txst act = execStateT (runReaderT (_unTransactionM act) tenv) txst - - -- | "Magic" capability 'COINBASE' used in the coin contract to -- constrain coinbase calls. -- @@ -333,7 +332,7 @@ applyCmd -> ApplyCmdExecutionContext -- ^ is this a local or send execution context? -> IO (T3 (CommandResult [TxLogJson]) ModuleCache (S.Set PactWarning)) -applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxInBlock spv cmd initialGas mcache0 callCtx = do +applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxInBlock spv cmd initialGas mcache0 callCtx = withEvent "applyCmd" $ do T2 cr st <- runTransactionM cenv txst applyBuyGas let cache = _txCache st @@ -877,7 +876,7 @@ runPayload => Command (Payload PublicMeta ParsedCode) -> NamespacePolicy -> TransactionM logger p (CommandResult [TxLogJson]) -runPayload cmd nsp = do +runPayload cmd nsp = withEvent "runPayload" $ do g0 <- use txGasUsed interp <- gasInterpreter g0 @@ -907,7 +906,7 @@ runGenesis -> NamespacePolicy -> Interpreter p -> TransactionM logger p (CommandResult [TxLogJson]) -runGenesis cmd nsp interp = case payload of +runGenesis cmd nsp interp = withEvent "runGenesis" $ case payload of Exec pm -> applyExec 0 interp pm signers verifiersWithNoProof chash nsp Continuation ym -> @@ -1107,7 +1106,7 @@ applyContinuation' initialGas interp cm@(ContMsg pid s rb d _) senderSigs hsh ns -- see: 'pact/coin-contract/coin.pact#fund-tx' -- buyGas :: (Logger logger) => TxContext -> Command (Payload PublicMeta ParsedCode) -> Miner -> TransactionM logger p () -buyGas txCtx cmd (Miner mid mks) = go +buyGas txCtx cmd (Miner mid mks) = withEvent "buyGas" $ go where isChainweb224Pact = guardCtx chainweb224Pact txCtx sender = view (cmdPayload . pMeta . pmSender) cmd @@ -1243,7 +1242,7 @@ redeemGas txCtx cmd (Miner mid mks) = do fee <- gasSupplyOf <$> use txGasUsed <*> view txGasPrice -- if we're past chainweb 2.24, we don't use defpacts for gas if guardCtx chainweb224Pact txCtx - then do + then withEvent "redeemGas" $ do total <- gasSupplyOf <$> view txGasLimit <*> view txGasPrice let (redeemGasTerm, redeemGasCmd) = mkRedeemGasTerm mid mks sender total fee @@ -1263,7 +1262,7 @@ redeemGas txCtx cmd (Miner mid mks) = do [] rgHash managedNamespacePolicy - else do + else withEvent "redeemGasOld" $ do GasId gid <- use txGasId >>= \case Nothing -> fatal $! "redeemGas: no gas id in scope for gas refunds" Just g -> return g diff --git a/src/Chainweb/Pact5/TransactionExec.hs b/src/Chainweb/Pact5/TransactionExec.hs index 1e22249489..685b3a6036 100644 --- a/src/Chainweb/Pact5/TransactionExec.hs +++ b/src/Chainweb/Pact5/TransactionExec.hs @@ -131,6 +131,7 @@ import qualified Pact.Types.Capability as Pact4 import qualified Pact.Types.Names as Pact4 import qualified Pact.Types.Runtime as Pact4 import qualified Pact.Core.Errors as Pact5 +import Utils.Logging.Trace -- Note [Throw out verifier proofs eagerly] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -161,6 +162,8 @@ newtype TransactionM logger a , MonadReader (TransactionEnv logger) , MonadError (Pact5.PactError Info) , MonadThrow + , MonadCatch + , MonadMask , MonadIO ) @@ -174,7 +177,7 @@ chargeGas info gasArgs = do -- nasty... perhaps later convert verifier plugins to use GasM instead of tracking "gas remaining" -- TODO: Verifiers are also tied to Pact enough that this is going to be an annoying migration runVerifiers :: Logger logger => TxContext -> Command (Payload PublicMeta ParsedCode) -> TransactionM logger () -runVerifiers txCtx cmd = do +runVerifiers txCtx cmd = withEvent "runVerifiers" $ do logger <- view txEnvLogger let v = _chainwebVersion txCtx let gasLimit = cmd ^. cmdPayload . pMeta . pmGasLimit @@ -252,7 +255,7 @@ applyLocal -> Command (Payload PublicMeta ParsedCode) -- ^ command with payload to execute -> IO (CommandResult [TxLog ByteString] (Pact5.PactError Info)) -applyLocal logger maybeGasLogger coreDb txCtx spvSupport cmd = do +applyLocal logger maybeGasLogger coreDb txCtx spvSupport cmd = withEvent "applyLocal" $ do let gasLogsEnabled = maybe GasLogsDisabled (const GasLogsEnabled) maybeGasLogger let gasLimitGas :: Gas = cmd ^. cmdPayload . pMeta . pmGasLimit . _GasLimit @@ -331,7 +334,7 @@ applyCmd -> Command (Payload PublicMeta ParsedCode) -- ^ command with payload to execute -> IO (Either Pact5GasPurchaseFailure (CommandResult [TxLog ByteString] (Pact5.PactError Info))) -applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = do +applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = withEvent "applyCmd" $ do logDebug_ logger $ "applyCmd: " <> sshow (_cmdHash cmd) let flags = Set.fromList [ FlagDisableRuntimeRTC @@ -464,7 +467,7 @@ applyCoinbase -> TxContext -- ^ tx metadata and parent header -> IO (Either Pact5CoinbaseError (CommandResult [TxLog ByteString] Void)) -applyCoinbase logger db reward txCtx = do +applyCoinbase logger db reward txCtx = withEvent "applyCoinbase" $ do -- for some reason this is the base64-encoded hash, rather than the binary hash let coinbaseHash = Hash $ SB.toShort $ T.encodeUtf8 $ blockHashToText parentBlockHash -- applyCoinbase is when upgrades happen, so we call applyUpgrades first @@ -555,7 +558,7 @@ runGenesisPayload -> TxContext -> Command (Payload PublicMeta ParsedCode) -> IO (Either (Pact5.PactError Info) (CommandResult [TxLog ByteString] Void)) -runGenesisPayload logger db spv ctx cmd = do +runGenesisPayload logger db spv ctx cmd = withEvent "runGenesisPayload" $ do gasRef <- newIORef (MilliGas 0) let gasEnv = GasEnv gasRef Nothing freeGasModel let txEnv = TransactionEnv logger gasEnv @@ -605,7 +608,7 @@ runPayload -> TxIdxInBlock -> Command (Payload PublicMeta ParsedCode) -> TransactionM logger EvalResult -runPayload execMode execFlags db spv specialCaps namespacePolicy gasEnv txCtx txIdxInBlock cmd = do +runPayload execMode execFlags db spv specialCaps namespacePolicy gasEnv txCtx txIdxInBlock cmd = withEvent "runPayload" $ do -- Note [Throw out verifier proofs eagerly] let !verifiersWithNoProof = (fmap . fmap) (\_ -> ()) verifiers @@ -670,7 +673,7 @@ runUpgrade -> TxContext -> Command (Payload PublicMeta ParsedCode) -> IO () -runUpgrade _logger db txContext cmd = case payload ^. pPayload of +runUpgrade _logger db txContext cmd = withEvent "runUpgrade" $ case payload ^. pPayload of Exec pm -> do freeGasEnv <- mkFreeGasEnv GasLogsDisabled evalExec (RawCode (_pcCode (_pmCode pm))) Transactional @@ -735,7 +738,7 @@ buyGas -> TxContext -> Command (Payload PublicMeta ParsedCode) -> IO (Either Pact5BuyGasError EvalResult) -buyGas logger origGasEnv db txCtx cmd = do +buyGas logger origGasEnv db txCtx cmd = withEvent "buyGas" $ do let gasEnv = origGasEnv & geGasModel . gmGasLimit .~ Just (MilliGasLimit (MilliGas 1_500_000)) logFunctionText logger L.Debug $ "buying gas for " <> sshow (_cmdHash cmd) @@ -845,7 +848,7 @@ redeemGas :: (Logger logger) -> Command (Payload PublicMeta ParsedCode) -> IO (Either Pact5RedeemGasError EvalResult) redeemGas logger db txCtx gasUsed maybeFundTxPactId cmd - | isChainweb224Pact, Nothing <- maybeFundTxPactId = do + | isChainweb224Pact, Nothing <- maybeFundTxPactId = withEvent "redeemGas" $ do logFunctionText logger L.Debug $ "redeeming gas (post-2.24) for " <> sshow (_cmdHash cmd) -- if we're past chainweb 2.24, we don't use defpacts for gas; see 'pact/coin-contract/coin.pact#redeem-gas' @@ -870,7 +873,7 @@ redeemGas logger db txCtx gasUsed maybeFundTxPactId cmd Right evalResult -> do pure $ Right evalResult - | not isChainweb224Pact, Just fundTxPactId <- maybeFundTxPactId = do + | not isChainweb224Pact, Just fundTxPactId <- maybeFundTxPactId = withEvent "redeemGasOld" $ do freeGasEnv <- mkFreeGasEnv GasLogsDisabled logFunctionText logger L.Debug $ "redeeming gas (pre-2.24) for " <> sshow (_cmdHash cmd) diff --git a/src/Chainweb/Sync/WebBlockHeaderStore.hs b/src/Chainweb/Sync/WebBlockHeaderStore.hs index 887e669996..069b564051 100644 --- a/src/Chainweb/Sync/WebBlockHeaderStore.hs +++ b/src/Chainweb/Sync/WebBlockHeaderStore.hs @@ -218,7 +218,7 @@ getBlockPayload s candidateStore priority maybeOrigin h = do Nothing -> lookupPayloadWithHeight cas (Just $ view blockHeight h) payloadHash >>= \case Just !x -> return $! payloadWithOutputsToPayloadData x Nothing -> memo memoMap payloadHash $ \k -> - pullOrigin (view blockHeight h) k maybeOrigin >>= \case + withEventOnChain h ("FETCH PAYLOAD " <> T.unpack (blockHeaderShortDescription h)) $ pullOrigin (view blockHeight h) k maybeOrigin >>= \case Nothing -> do t <- queryPayloadTask (view blockHeight h) k pQueueInsert queue t @@ -484,11 +484,12 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl | hsh == view blockPayloadHash hdr -> CheckablePayloadWithOutputs pwo _ -> CheckablePayload p - outs <- trace logfun - (traceLabel "pact") - (view blockHash hdr) - (length (view payloadDataTransactions p)) - $ pact hdr payload + outs <- withEventOnChain (_chainId hdr) ("VALIDATE PAYLOAD " <> T.unpack (blockHeaderShortDescription hdr)) $ + trace logfun + (traceLabel "pact") + (view blockHash hdr) + (length (view payloadDataTransactions p)) + $ pact hdr payload addNewPayload (_webBlockPayloadStoreCas payloadStore) (view blockHeight hdr) outs queryBlockHeaderTask ck@(ChainValue cid k) @@ -522,7 +523,7 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl pullOrigin ck@(ChainValue cid k) (Just origin) = do let originEnv = setResponseTimeout pullOriginResponseTimeout $ peerInfoClientEnv mgr origin logg Debug $ taskMsg ck "lookup origin" - !r <- trace logfun (traceLabel "pullOrigin") k 0 + !r <- withEventOnChain cid ("FETCH HEADER " <> T.unpack (blockHashToTextShort k)) $ trace logfun (traceLabel "pullOrigin") k 0 $ TDB.lookup (rDb cid originEnv) k logg Debug $ taskMsg ck "received from origin" return r diff --git a/src/Utils/Logging/Trace.hs b/src/Utils/Logging/Trace.hs index d49018eec6..6dafd46803 100644 --- a/src/Utils/Logging/Trace.hs +++ b/src/Utils/Logging/Trace.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Utils.Logging.Trace @@ -25,22 +26,38 @@ module Utils.Logging.Trace ( trace , trace' , Trace +, eventStart +, eventEnd +, withCountedEvent +, withEvent +, eventStartOnChain +, eventEndOnChain +, withEventOnChain ) where import Control.DeepSeq import Control.Monad.IO.Class +import Control.Monad.Catch import Control.StopWatch import Data.Aeson +import Data.IORef +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map import qualified Data.Text as T +import Data.Tuple +import Debug.Trace (traceEventIO) import GHC.Generics import System.Clock +import System.IO.Unsafe import System.LogLevel -- internal modules +import Chainweb.ChainId import Chainweb.Time import Data.LogMessage @@ -71,8 +88,12 @@ instance ToJSON Trace where {-# INLINE toJSON #-} {-# INLINE toEncoding #-} +eventCounters :: IORef (Map String Int) +eventCounters = unsafePerformIO $ newIORef Map.empty +{-# noinline eventCounters #-} + trace - :: MonadIO m + :: (MonadIO m) => ToJSON param => (LogLevel -> JsonLog Trace -> IO ()) -> T.Text @@ -84,7 +105,7 @@ trace logg label param weight a = trace' logg label (const param) (const weight) a trace' - :: MonadIO m + :: (MonadIO m) => ToJSON param => (LogLevel -> JsonLog Trace -> IO ()) -> T.Text @@ -99,3 +120,37 @@ trace' logg label calcParam calcWeight a = do (calcWeight r) (fromIntegral $ toNanoSecs t `div` 1000) return r + +eventStart :: MonadIO m => String -> m () +eventStart msg = liftIO $ traceEventIO ("START " ++ msg) +eventEnd :: MonadIO m => String -> m () +eventEnd msg = liftIO $ traceEventIO ("STOP " ++ msg) + +withCountedEvent :: (MonadMask m, MonadIO m) => String -> m a -> m a +withCountedEvent str act = do + !ctr <- liftIO $ atomicModifyIORef' + eventCounters + (swap . Map.alterF (\(fromMaybe 0 -> r) -> (r, Just (r + 1))) str) + withEvent (str <> " " <> show ctr) act + +withEvent :: (MonadMask m, MonadIO m) => String -> m a -> m a +withEvent msg act = do + liftIO $ eventStart msg + act `finally` + liftIO (eventEnd msg) + +eventStartOnChain :: (HasChainId cid, MonadMask m, MonadIO m) => cid -> String -> m () +eventStartOnChain cid msg = do + let chainMsg = msg <> " (" <> T.unpack (chainIdToText $ _chainId cid) <> ")" + liftIO $ eventStart chainMsg + +eventEndOnChain :: (HasChainId cid, MonadMask m, MonadIO m) => cid -> String -> m () +eventEndOnChain cid msg = do + let chainMsg = msg <> " (" <> T.unpack (chainIdToText $ _chainId cid) <> ")" + liftIO $ eventEnd chainMsg + +withEventOnChain :: (HasChainId cid, MonadMask m, MonadIO m) => cid -> String -> m a -> m a +withEventOnChain cid msg act = do + eventStartOnChain cid msg + act `finally` + liftIO (eventEndOnChain cid msg) diff --git a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs index f7689e452c..6a032162de 100644 --- a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs +++ b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs @@ -46,6 +46,8 @@ import Chainweb.WebBlockHeaderDB import Chainweb.Storage.Table.RocksDB import Chainweb.BlockHeight +import Control.Monad +import Control.DeepSeq data TestBlockDb = TestBlockDb { _bdbWebBlockHeaderDb :: WebBlockHeaderDb @@ -53,6 +55,9 @@ data TestBlockDb = TestBlockDb , _bdbCut :: MVar Cut } +instance NFData TestBlockDb where + rnf (TestBlockDb a b c) = rnf a `seq` rnf b `seq` rnf c + instance HasChainwebVersion TestBlockDb where _chainwebVersion = _chainwebVersion . _bdbWebBlockHeaderDb diff --git a/test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs b/test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs index 73c9d85fa7..38ae5895e6 100644 --- a/test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs +++ b/test/unit/Chainweb/Test/Pact5/TransactionExecTest.hs @@ -40,7 +40,6 @@ import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Decimal import Data.Functor.Product -import Data.HashMap.Strict qualified as HashMap import Data.IORef import Data.Maybe (fromMaybe) import Data.Set qualified as Set @@ -74,6 +73,7 @@ import Text.Printf import Chainweb.Logger import Chainweb.Pact.Backend.InMemDb qualified as InMemDb import Chainweb.Pact.Backend.Types +import qualified Data.Map as Map tests :: RocksDb -> TestTree tests baseRdb = testGroup "Pact5 TransactionExecTest"