From 065588e65f4199dca6b59bc19d07a7b99f6b0b00 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 | 6 +- bench/Chainweb/Pact/Backend/ApplyCmd.hs | 205 ++++++++++++++++++ bench/Chainweb/Pact/Backend/ForkingBench.hs | 10 +- chainweb.cabal | 8 + .../src/Chainweb/Storage/Table/RocksDB.hs | 11 + src/Chainweb/BlockHeaderDB/Internal.hs | 3 + src/Chainweb/Logger.hs | 4 + src/Chainweb/Pact/PactService.hs | 5 +- src/Chainweb/Payload/PayloadStore.hs | 10 + src/Chainweb/WebBlockHeaderDB.hs | 4 + test/lib/Chainweb/Test/Cut/TestBlockDb.hs | 4 + 11 files changed, 263 insertions(+), 7 deletions(-) create mode 100644 bench/Chainweb/Pact/Backend/ApplyCmd.hs diff --git a/bench/Bench.hs b/bench/Bench.hs index d90af9e571..c2b7a96118 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -10,6 +10,7 @@ where import Criterion.Main +import qualified Chainweb.Pact.Backend.ApplyCmd as ApplyCmd import qualified Chainweb.Pact.Backend.Bench as Checkpointer import qualified Chainweb.Pact.Backend.ForkingBench as ForkingBench import qualified JSONEncoding @@ -17,14 +18,17 @@ import qualified JSONEncoding import Chainweb.Storage.Table.RocksDB import Chainweb.Version.RecapDevelopment import Chainweb.Version.Development +import Chainweb.Version.Pact5Development import Chainweb.Version.Registry main :: IO () main = withTempRocksDb "benchmarks" $ \rdb -> do registerVersion RecapDevelopment registerVersion Development + registerVersion Pact5Development defaultMain - [ Checkpointer.bench + [ ApplyCmd.bench rdb + , Checkpointer.bench , ForkingBench.bench rdb , JSONEncoding.benchmarks ] diff --git a/bench/Chainweb/Pact/Backend/ApplyCmd.hs b/bench/Chainweb/Pact/Backend/ApplyCmd.hs new file mode 100644 index 0000000000..df66a4c6e6 --- /dev/null +++ b/bench/Chainweb/Pact/Backend/ApplyCmd.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Chainweb.Pact.Backend.ApplyCmd + ( bench + ) + where + +import Chainweb.Pact4.Backend.ChainwebPactDb qualified as Pact4 +import Chainweb.Pact4.SPV qualified as Pact4 +import Chainweb.Pact4.Transaction qualified as Pact4 +import Chainweb.Pact4.TransactionExec qualified as Pact4 +import Chainweb.Pact4.Validations qualified as Pact4 +import Pact.Parse qualified as Pact4 +import Pact.Types.Command qualified as Pact4 +import Pact.Types.Hash qualified as Pact4 +import Pact.Types.Runtime qualified as Pact4 +import Pact.Types.SPV qualified as Pact4 +import Chainweb.Pact4.Types qualified as Pact4 +import Chainweb.Test.Pact4.Utils qualified as Pact4 + +import Chainweb.Pact.Types (ApplyCmdExecutionContext(..)) +import Chainweb.BlockHeader +import Chainweb.Graph (singletonChainGraph) +import Chainweb.Logger +import Chainweb.Miner.Pact (noMiner) +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils (openSQLiteConnection, closeSQLiteConnection, chainwebPragmas) +import Chainweb.Pact.PactService (initialPayloadState, withPactService) +import Chainweb.Pact.PactService.Checkpointer (readFrom, SomeBlockM(..)) +import Chainweb.Pact.Types +import Chainweb.Pact5.Transaction +import Chainweb.Pact5.TransactionExec +import Chainweb.Pact5.Types qualified as Pact5 +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Cut.TestBlockDb (TestBlockDb (_bdbPayloadDb, _bdbWebBlockHeaderDb), mkTestBlockDb) +import Chainweb.Test.Pact5.CmdBuilder qualified as Pact5 +import Chainweb.Test.Pact5.Utils qualified as Pact5 +import Chainweb.Test.Pact5.Utils (getTestLogLevel) +import Chainweb.Test.TestVersions +import Chainweb.Test.Utils +import Chainweb.Utils (T2(..), T3(..)) +import Chainweb.Version +import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) +import Control.Concurrent (forkIO, throwTo) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) +import Control.DeepSeq +import Control.Exception (AsyncException(..)) +import Control.Lens hiding (only) +import Control.Monad (void) +import Control.Monad.IO.Class +import Control.Monad.Reader +import Criterion.Main qualified as C +import Criterion.Types (Benchmarkable(..)) +import Data.ByteString (ByteString) +import Data.Functor.Product +import Data.Text.IO qualified as T +import Database.SQLite3.Direct (Database(..)) +import Pact.Core.Command.Types qualified as Pact5 +import Pact.Core.Errors qualified as Pact5 +import Pact.Core.Evaluate qualified as Pact5 +import Pact.Core.Gas.TableGasModel qualified as Pact5 +import Pact.Core.Gas.Types qualified as Pact5 +import Pact.Core.Hash qualified as Pact5 +import Pact.Core.Names qualified as Pact5 +import Pact.Core.PactValue qualified as Pact5 +import Pact.Core.Persistence qualified as Pact5 +import Pact.Core.SPV qualified as Pact5 +import Pact.Core.Signer qualified as Pact5 +import Pact.Core.Verifiers qualified as Pact5 +import Pact.JSON.Encode qualified as J +import Pact.Types.Gas qualified as Pact4 +import Pact.Types.KeySet qualified as Pact4 +import System.IO.Unsafe (unsafePerformIO) + +deriving newtype instance NFData Database + +instance NFData (PactServiceEnv logger tbl) where + rnf !_ = () + +bench :: RocksDb -> C.Benchmark +bench rdb = C.bgroup "applyCmd" + [ C.bgroup "Pact5" [benchApplyCmd pact5Version rdb (SomeBlockM $ Pair (error "Pact4") applyCmd5)] + , C.bgroup "Pact4" [benchApplyCmd pact4Version rdb (SomeBlockM $ Pair applyCmd4 (error "Pact5"))] + ] + +benchApplyCmd :: ChainwebVersion -> RocksDb -> SomeBlockM GenericLogger RocksDbTable a -> C.Benchmark +benchApplyCmd ver rdb act = + let setupEnv = do + sql <- openSQLiteConnection "" chainwebPragmas + tdb <- mkTestBlockDb ver =<< testRocksDb "readFromAfterGenesis" rdb + bhdb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb tdb) chain0 + logger <- testLogger + + psEnvVar <- newEmptyMVar + tid <- forkIO $ void $ withPactService ver chain0 logger Nothing bhdb (_bdbPayloadDb tdb) sql testPactServiceConfig $ do + initialPayloadState ver chain0 + psEnv <- ask + liftIO $ putMVar psEnvVar psEnv + psEnv <- readMVar psEnvVar + + pure (sql, tdb, bhdb, logger, tid, psEnv) + + cleanupEnv (sql, _, _, _, tid, _) = do + closeSQLiteConnection sql + throwTo tid ThreadKilled + in + C.envWithCleanup setupEnv cleanupEnv $ \ ~(_sql, _tdb, _bhdb, _logger, _tid, psEnv) -> + C.bench "todo change this" $ C.whnfIO $ do + T2 a _finalPactState <- runPactServiceM (PactServiceState mempty) psEnv $ do + throwIfNoHistory =<< + readFrom + (Just $ ParentHeader (gh ver chain0)) + act + + return a + +applyCmd4 :: Pact4.PactBlockM GenericLogger RocksDbTable (Pact4.CommandResult [Pact4.TxLogJson]) --(CommandResult [TxLog ByteString] (PactError Info)) +applyCmd4 = do + logger <- view (psServiceEnv . psLogger) + let txCtx = Pact4.TxContext + { Pact4._tcParentHeader = ParentHeader (gh pact4Version chain0) + , Pact4._tcPublicMeta = Pact4.noPublicMeta + , Pact4._tcMiner = noMiner + } + let gasModel = Pact4.getGasModel txCtx + pactDbEnv <- view (psBlockDbEnv . Pact4.cpPactDbEnv) + + cmd <- liftIO $ Pact4.buildCwCmd "fakeNonce" pact4Version + $ set Pact4.cbSigners + [ Pact4.mkEd25519Signer' Pact4.sender00 [] + ] + $ set Pact4.cbChainId chain0 + $ set Pact4.cbRPC (Pact4.mkExec' "(fold + 0 [1 2 3 4 5])") + $ Pact4.defaultCmd + + T3 cmdResult _moduleCache _warnings <- liftIO $ + Pact4.applyCmd + pact4Version + logger + Nothing + Nothing + pactDbEnv + noMiner + gasModel + txCtx + (TxBlockIdx 0) + Pact4.noSPVSupport + (fmap Pact4.payloadObj cmd) + (Pact4.Gas 1) + mempty -- module cache + ApplySend + + pure cmdResult + +applyCmd5 :: Pact5.PactBlockM GenericLogger RocksDbTable (Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info)) +applyCmd5 = do + cmd <- liftIO $ Pact5.buildCwCmd pact5Version (Pact5.defaultCmd chain0) + { Pact5._cbRPC = Pact5.mkExec' "(fold + 0 [1 2 3 4 5])" + , Pact5._cbGasPrice = Pact5.GasPrice 2 + , Pact5._cbGasLimit = Pact5.GasLimit (Pact5.Gas 500) + -- no caps should be equivalent to the GAS cap + , Pact5._cbSigners = [Pact5.mkEd25519Signer' Pact5.sender00 []] + } + logger <- view (psServiceEnv . psLogger) + let txCtx = Pact5.TxContext {Pact5._tcParentHeader = ParentHeader (gh pact5Version chain0), Pact5._tcMiner = noMiner} + + Pact5.pactTransaction Nothing $ \pactDb -> do + r <- applyCmd logger Nothing pactDb txCtx (TxBlockIdx 0) Pact5.noSPVSupport (Pact5.Gas 1) (view payloadObj <$> cmd) + case r of + Left err -> error $ show err + Right a -> pure a +{-# noinline applyCmd5 #-} + +chain0 :: ChainId +chain0 = unsafeChainId 0 + +gh :: ChainwebVersion -> ChainId -> BlockHeader +gh = genesisBlockHeader + +pact4Version :: ChainwebVersion +pact4Version = instantCpmTestVersion singletonChainGraph + +pact5Version :: ChainwebVersion +pact5Version = pact5InstantCpmTestVersion singletonChainGraph + +testLogger :: IO GenericLogger +testLogger = do + logLevel <- liftIO getTestLogLevel + pure $ genericLogger logLevel T.putStrLn diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index 6ccbffb3df..62d9c303ca 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/bench/Chainweb/Pact/Backend/ForkingBench.hs @@ -98,7 +98,7 @@ import Chainweb.Pact.Utils (toTxCreationTime) import Chainweb.Payload import Chainweb.Payload.PayloadStore import Chainweb.Payload.PayloadStore.InMemory -import Chainweb.Test.TestVersions (slowForkingCpmTestVersion) +import Chainweb.Test.TestVersions (slowForkingCpmTestVersion, pact5SlowCpmTestVersion) import Chainweb.Time import qualified Chainweb.Pact4.Transaction as Pact4 import Chainweb.Utils @@ -430,12 +430,15 @@ testMemPoolAccess txsPerBlock accounts = do mkTransferCaps :: ReceiverName -> Amount -> (Account, NonEmpty (DynKeyPair, [SigCapability])) -> (Account, NonEmpty (DynKeyPair, [SigCapability])) mkTransferCaps (ReceiverName (Account r)) (Amount m) (s@(Account ss),ks) = (s, (caps <$) <$> ks) where + caps = [] + {- caps = [gas,tfr] gas = SigCapability (QualifiedName "coin" "GAS" (mkInfo "coin.GAS")) [] tfr = SigCapability (QualifiedName "coin" "TRANSFER" (mkInfo "coin.TRANSFER")) [ PLiteral $ LString $ T.pack ss , PLiteral $ LString $ T.pack r , PLiteral $ LDecimal m] + -} -- -------------------------------------------------------------------------- -- -- Utils @@ -444,7 +447,8 @@ cid :: ChainId cid = someChainId testVer testVer :: ChainwebVersion -testVer = slowForkingCpmTestVersion petersonChainGraph +--testVer = slowForkingCpmTestVersion petersonChainGraph +testVer = pact5SlowCpmTestVersion petersonChainGraph -- MORE CODE DUPLICATION @@ -461,7 +465,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/chainweb.cabal b/chainweb.cabal index 516b413c46..5e47815e69 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.Pact.Backend.ApplyCmd Chainweb.Pact.Backend.Bench Chainweb.Pact.Backend.ForkingBench Chainweb.Utils.Bench @@ -880,6 +881,13 @@ 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 + , property-matchers , bytestring >= 0.10.12 , chainweb-storage >= 0.1 , containers >= 0.5 diff --git a/libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs b/libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs index 11811baee0..888a11dca6 100644 --- a/libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs +++ b/libs/chainweb-storage/src/Chainweb/Storage/Table/RocksDB.hs @@ -88,6 +88,7 @@ module Chainweb.Storage.Table.RocksDB ) where import Control.Exception(evaluate) +import Control.DeepSeq import Control.Lens import Control.Monad import Control.Monad.Catch @@ -298,6 +299,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 @@ -313,6 +317,13 @@ data RocksDbTable k v = RocksDbTable , _rocksDbTableDb :: !R.DB } +instance NFData (RocksDbTable k v) where + rnf (RocksDbTable a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + +-- TODO: THIS IS AN ORPHAN +instance NFData R.DB where + rnf !_ = () + instance NoThunks (RocksDbTable k v) where wNoThunks ctx (RocksDbTable a b c d) = allNoThunks [ noThunks ctx a diff --git a/src/Chainweb/BlockHeaderDB/Internal.hs b/src/Chainweb/BlockHeaderDB/Internal.hs index f272bb8b7a..775f92f557 100644 --- a/src/Chainweb/BlockHeaderDB/Internal.hs +++ b/src/Chainweb/BlockHeaderDB/Internal.hs @@ -157,6 +157,9 @@ data BlockHeaderDb = BlockHeaderDb -- isn't known } +instance NFData BlockHeaderDb where + rnf (BlockHeaderDb a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + instance HasChainId BlockHeaderDb where _chainId = _chainDbId {-# INLINE _chainId #-} 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/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 4ab17d1767..be090b08bf 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 diff --git a/src/Chainweb/Payload/PayloadStore.hs b/src/Chainweb/Payload/PayloadStore.hs index 3ff57ca078..38d6d8383e 100644 --- a/src/Chainweb/Payload/PayloadStore.hs +++ b/src/Chainweb/Payload/PayloadStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -149,6 +150,9 @@ data TransactionDb_ a tbl = TransactionDb -- `_newTransactionDbBlockTransactionsTbl`. instead, which is indexed. } +instance NFData (TransactionDb_ a tbl) where + rnf !_ = () + -- | Store of the 'BlockOutputs' for all blocks. -- type BlockOutputsStore tbl = BlockOutputsStore_ ChainwebMerkleHashAlgorithm tbl @@ -191,6 +195,9 @@ data PayloadCache_ a tbl = PayloadCache -- (tens of thousands blocks per second) } +instance NFData (PayloadCache_ a tbl) where + rnf !_ = () + type PayloadDb tbl = PayloadDb_ ChainwebMerkleHashAlgorithm tbl data PayloadDb_ a tbl = PayloadDb @@ -198,6 +205,9 @@ data PayloadDb_ a tbl = PayloadDb , _payloadCache :: !(PayloadCache_ a tbl) } +instance NFData (PayloadDb_ a tbl) where + rnf (PayloadDb a b) = rnf a `seq` rnf b + type HeightedCas c t v = c (t (BlockHeight, CasKeyType v) v) (BlockHeight, CasKeyType v) v type CanReadablePayloadCas tbl = CanReadablePayloadCas_ ChainwebMerkleHashAlgorithm tbl type CanReadablePayloadCas_ a tbl = diff --git a/src/Chainweb/WebBlockHeaderDB.hs b/src/Chainweb/WebBlockHeaderDB.hs index 121a224338..bdb71ff663 100644 --- a/src/Chainweb/WebBlockHeaderDB.hs +++ b/src/Chainweb/WebBlockHeaderDB.hs @@ -40,6 +40,7 @@ module Chainweb.WebBlockHeaderDB import Chainweb.Time import Control.Arrow +import Control.DeepSeq import Control.Lens import Control.Monad import Control.Monad.Catch @@ -96,6 +97,9 @@ instance HasChainwebVersion WebBlockHeaderDb where _chainwebVersion = _webChainwebVersion {-# INLINE _chainwebVersion #-} +instance NFData WebBlockHeaderDb where + rnf (WebBlockHeaderDb a b) = rnf a `seq` rnf b + webBlockHeaderDb :: Getter WebBlockHeaderDb (HM.HashMap ChainId BlockHeaderDb) webBlockHeaderDb = to _webBlockHeaderDb diff --git a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs index e9602283b5..8ef546daf6 100644 --- a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs +++ b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs @@ -44,6 +44,7 @@ import Chainweb.WebBlockHeaderDB import Chainweb.Storage.Table.RocksDB import Chainweb.BlockHeight import Control.Monad +import Control.DeepSeq data TestBlockDb = TestBlockDb { _bdbWebBlockHeaderDb :: WebBlockHeaderDb @@ -51,6 +52,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