From 176944bfc67c2e1433428051b79dc0b005b95129 Mon Sep 17 00:00:00 2001 From: chessai Date: Thu, 23 Jan 2025 15:46:27 -0600 Subject: [PATCH] pact5 preliminary benchmarks Change-Id: I241132deae7e66619674e1c08db668a1d3500ab8 --- bench/Bench.hs | 31 ++- bench/Chainweb/Pact/Backend/ApplyCmd.hs | 201 +++++++++++++++ bench/Chainweb/Pact/Backend/ForkingBench.hs | 212 +++++----------- bench/Chainweb/Pact/Backend/PactService.hs | 255 ++++++++++++++++++++ bench/Chainweb/Utils/Bench.hs | 92 ++++++- chainweb.cabal | 9 + test/lib/Chainweb/Test/Cut/TestBlockDb.hs | 14 ++ 7 files changed, 640 insertions(+), 174 deletions(-) create mode 100644 bench/Chainweb/Pact/Backend/ApplyCmd.hs create mode 100644 bench/Chainweb/Pact/Backend/PactService.hs diff --git a/bench/Bench.hs b/bench/Bench.hs index d90af9e571..2439897e9d 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,30 +1,35 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + -- | -- Module: JSONEncoding -- Copyright: Copyright © 2021 Kadena LLC. -- License: MIT -- Maintainer: Lars Kuhtz -- Stability: experimental -module Main (main) -where - -import Criterion.Main +module Main (main) where -import qualified Chainweb.Pact.Backend.Bench as Checkpointer -import qualified Chainweb.Pact.Backend.ForkingBench as ForkingBench -import qualified JSONEncoding - -import Chainweb.Storage.Table.RocksDB -import Chainweb.Version.RecapDevelopment -import Chainweb.Version.Development -import Chainweb.Version.Registry +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.Pact.Backend.PactService qualified as PactService +import Chainweb.Storage.Table.RocksDB (withTempRocksDb) +import Chainweb.Version.Development (pattern Development) +import Chainweb.Version.RecapDevelopment (pattern RecapDevelopment) +import Chainweb.Version.Registry (registerVersion) +import Criterion.Main (defaultMain) +import JSONEncoding qualified main :: IO () main = withTempRocksDb "benchmarks" $ \rdb -> do registerVersion RecapDevelopment registerVersion Development + defaultMain - [ Checkpointer.bench + [ ApplyCmd.bench rdb + , Checkpointer.bench , ForkingBench.bench rdb , JSONEncoding.benchmarks + , PactService.bench rdb ] diff --git a/bench/Chainweb/Pact/Backend/ApplyCmd.hs b/bench/Chainweb/Pact/Backend/ApplyCmd.hs new file mode 100644 index 0000000000..d581f826bc --- /dev/null +++ b/bench/Chainweb/Pact/Backend/ApplyCmd.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Chainweb.Pact.Backend.ApplyCmd + ( bench + ) + where + +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB (BlockHeaderDb) +import Chainweb.Graph (singletonChainGraph) +import Chainweb.Logger +import Chainweb.Miner.Pact (noMiner) +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.Pact4.Backend.ChainwebPactDb qualified as Pact4 +import Chainweb.Pact4.Transaction qualified as Pact4 +import Chainweb.Pact4.TransactionExec qualified as Pact4 +import Chainweb.Pact4.Types qualified as Pact4 +import Chainweb.Pact5.Transaction +import Chainweb.Pact5.TransactionExec qualified as Pact5 +import Chainweb.Pact5.Types qualified as Pact5 +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Cut.TestBlockDb (TestBlockDb(..), mkTestBlockDbIO) +import Chainweb.Test.Pact4.Utils qualified as Pact4 +import Chainweb.Test.Pact5.CmdBuilder qualified as Pact5 +import Chainweb.Test.TestVersions +import Chainweb.Utils (T2(..), T3(..)) +import Chainweb.Utils.Bench +import Chainweb.Pact.Backend.Types (SQLiteEnv) +import Chainweb.Version +import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) +import Control.Concurrent (ThreadId, 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 Data.ByteString (ByteString) +import Data.Functor.Product +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.Types qualified as Pact5 +import Pact.Core.Persistence qualified as Pact5 +import Pact.Core.SPV qualified as Pact5 +import Pact.Types.Command qualified as Pact4 +import Pact.Types.Gas qualified as Pact4 +import Pact.Types.Runtime qualified as Pact4 +import Pact.Types.SPV qualified as Pact4 + +bench :: RocksDb -> C.Benchmark +bench rdb = C.bgroup "applyCmd" + [ C.bench "Pact5" $ benchApplyCmd pact5Version rdb (SomeBlockM $ Pair (error "Pact4") applyCmd5) + , C.bench "Pact4" $ benchApplyCmd pact4Version rdb (SomeBlockM $ Pair applyCmd4 (error "Pact5")) + ] + +data Env = Env + { sqlite :: !SQLiteEnv + , testBlockDb :: !TestBlockDb + , testBlockDbRocksDb :: !RocksDb + , blockHeaderDb :: !BlockHeaderDb + , logger :: !GenericLogger + , pactServiceThreadId :: !ThreadId + , pactServiceEnv :: !(PactServiceEnv GenericLogger RocksDbTable) + } + +instance NFData Env where + rnf !_ = () + +benchApplyCmd :: ChainwebVersion -> RocksDb -> SomeBlockM GenericLogger RocksDbTable a -> C.Benchmarkable +benchApplyCmd ver rdb act = + let setupEnv _ = do + sql <- openSQLiteConnection "" chainwebPragmas + T2 tdb tdbRdb <- mkTestBlockDbIO ver rdb + bhdb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb tdb) chain0 + lgr <- testLogger + + psEnvVar <- newEmptyMVar + tid <- forkIO $ void $ withPactService ver chain0 lgr Nothing bhdb (_bdbPayloadDb tdb) sql testPactServiceConfig $ do + initialPayloadState ver chain0 + psEnv <- ask + liftIO $ putMVar psEnvVar psEnv + psEnv <- readMVar psEnvVar + + pure $ Env + { sqlite = sql + , testBlockDb = tdb + , testBlockDbRocksDb = tdbRdb + , blockHeaderDb = bhdb + , logger = lgr + , pactServiceThreadId = tid + , pactServiceEnv = psEnv + } + + cleanupEnv _ env = do + closeSQLiteConnection env.sqlite + throwTo env.pactServiceThreadId ThreadKilled + deleteNamespaceRocksDb env.testBlockDbRocksDb + in + C.perBatchEnvWithCleanup setupEnv cleanupEnv $ \ ~env -> do + T2 a _finalPactState <- runPactServiceM (PactServiceState mempty) env.pactServiceEnv $ do + throwIfNoHistory =<< + readFrom + (Just $ ParentHeader (gh ver chain0)) + act + + return (NoopNFData a) + +applyCmd4 :: Pact4.PactBlockM GenericLogger RocksDbTable (Pact4.CommandResult [Pact4.TxLogJson]) --(CommandResult [TxLog ByteString] (PactError Info)) +applyCmd4 = do + lgr <- 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 + lgr + Nothing + Nothing + pactDbEnv + noMiner + gasModel + txCtx + (TxBlockIdx 0) + Pact4.noSPVSupport + (fmap Pact4.payloadObj cmd) + (Pact4.Gas 1) + mempty -- module cache + ApplySend + + pure cmdResult +{-# noinline applyCmd4 #-} + +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 []] + } + lgr <- view (psServiceEnv . psLogger) + let txCtx = Pact5.TxContext {Pact5._tcParentHeader = ParentHeader (gh pact5Version chain0), Pact5._tcMiner = noMiner} + + Pact5.pactTransaction Nothing $ \pactDb -> do + r <- Pact5.applyCmd lgr 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 diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index 6ccbffb3df..35ca351250 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/bench/Chainweb/Pact/Backend/ForkingBench.hs @@ -16,10 +16,39 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PartialTypeSignatures #-} + {-# OPTIONS_GHC -Wno-partial-type-signatures #-} module Chainweb.Pact.Backend.ForkingBench ( bench ) where +import Chainweb.BlockCreationTime +import Chainweb.BlockHeader +import Chainweb.BlockHeaderDB +import Chainweb.BlockHeaderDB.Internal +import Chainweb.ChainId +import Chainweb.Graph +import Chainweb.Logger +import Chainweb.Mempool.Mempool +import Chainweb.Miner.Pact +import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Backend.Utils +import Chainweb.Pact.PactService +import Chainweb.Pact.Service.BlockValidation +import Chainweb.Pact.Service.PactQueue +import Chainweb.Pact.Types +import Chainweb.Pact.Utils (toTxCreationTime) +import Chainweb.Pact4.Transaction qualified as Pact4 +import Chainweb.Payload +import Chainweb.Payload.PayloadStore +import Chainweb.Payload.PayloadStore.InMemory +import Chainweb.Storage.Table.HashMap hiding (toList) +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.TestVersions (slowForkingCpmTestVersion) +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Utils.Bench +import Chainweb.Version +import Chainweb.Version.Utils import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Lens hiding (elements, from, to, (.=)) @@ -27,8 +56,7 @@ import Control.Monad import Control.Monad.Catch import Control.Monad.Reader import Control.Monad.State -import qualified Criterion.Main as C - +import Criterion.Main qualified as C import Data.Aeson hiding (Error) import Data.ByteString (ByteString) import Data.Char @@ -38,33 +66,22 @@ import Data.FileEmbed import Data.Foldable (toList) import Data.IORef import Data.List (uncons) -import Data.List qualified as List import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty qualified as NEL import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M +import Data.Map.Strict qualified as M import Data.String import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Text.Encoding -import qualified Data.Text.IO as T -import qualified Data.Vector as V +import Data.Text.IO qualified as T +import Data.Vector qualified as V import Data.Word -import qualified Data.Yaml as Y - +import Data.Yaml qualified as Y import GHC.Generics hiding (from, to) - -import System.Environment -import System.LogLevel -import System.Random - -import Text.Printf - --- pact imports - import Pact.ApiReq import Pact.Types.Capability -import qualified Pact.Types.ChainId as Pact +import Pact.Types.ChainId qualified as Pact import Pact.Types.ChainMeta import Pact.Types.Command import Pact.Types.Crypto @@ -73,98 +90,26 @@ import Pact.Types.Info import Pact.Types.Names import Pact.Types.PactValue import Pact.Types.Util hiding (unwrap) - --- chainweb imports - -import Chainweb.BlockCreationTime -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB -import Chainweb.BlockHeaderDB.Internal -import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.ChainId -import Chainweb.Graph -import Chainweb.Logger -import Chainweb.Mempool.Mempool -import Chainweb.Miner.Pact -import Chainweb.Pact.Backend.Compaction qualified as C - -import Chainweb.Pact.Backend.Types -import Chainweb.Pact.Backend.Utils -import Chainweb.Pact.PactService -import Chainweb.Pact.Service.BlockValidation -import Chainweb.Pact.Service.PactQueue -import Chainweb.Pact.Types -import Chainweb.Pact.Utils (toTxCreationTime) -import Chainweb.Payload -import Chainweb.Payload.PayloadStore -import Chainweb.Payload.PayloadStore.InMemory -import Chainweb.Test.TestVersions (slowForkingCpmTestVersion) -import Chainweb.Time -import qualified Chainweb.Pact4.Transaction as Pact4 -import Chainweb.Utils -import Chainweb.Utils.Bench -import Chainweb.Version -import Chainweb.Version.Utils - -import Chainweb.Storage.Table.HashMap hiding (toList) -import Chainweb.Storage.Table.RocksDB - --- -------------------------------------------------------------------------- -- --- For testing with GHCI --- -_run :: [String] -> IO () -_run args = withTempRocksDb "forkingbench" $ \rdb -> - withArgs args $ C.defaultMain [bench rdb] +import System.LogLevel +import System.Random +import Text.Printf (printf) -- -------------------------------------------------------------------------- -- -- Benchmarks -data BenchConfig = BenchConfig - { numPriorBlocks :: Word64 - -- ^ number of blocks to create prior to benchmarking - , validate :: Validate - -- ^ whether or not to validate the blocks as part of the benchmark - , compact :: Compact - -- ^ whether or not to compact the pact database prior to benchmarking - , persistIntraBlockWrites :: IntraBlockPersistence - } - -defBenchConfig :: BenchConfig -defBenchConfig = BenchConfig - { numPriorBlocks = 100 - , validate = DontValidate - , compact = DontCompact - , persistIntraBlockWrites = PersistIntraBlockWrites - } - -data Compact = DoCompact | DontCompact - deriving stock (Eq) - -data Validate = DoValidate | DontValidate - deriving stock (Eq) - bench :: RocksDb -> C.Benchmark -bench rdb = C.bgroup "PactService" $ +bench rdb = C.bgroup "ForkingBench" $ [ forkingBench , doubleForkingBench - ] ++ map (oneBlock defBenchConfig) [1, 10, 50, 100] - ++ map (oneBlock validateCfg) [0, 1, 10, 50, 100] - ++ map (oneBlock validateCfg { persistIntraBlockWrites = DoNotPersistIntraBlockWrites }) - [0, 1, 10, 50, 100] - ++ map (oneBlock compactCfg) [0, 1, 10, 50, 100] - ++ map (oneBlock compactValidateCfg) [1, 10, 50, 100] + ] where - validateCfg = defBenchConfig { validate = DoValidate } - compactCfg = defBenchConfig { compact = DoCompact } - compactValidateCfg = compactCfg { validate = DoValidate } - - forkingBench = withResources rdb 10 Quiet DontCompact PersistIntraBlockWrites + forkingBench = withResources rdb 10 Quiet PersistIntraBlockWrites $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ -> C.bench "forkingBench" $ C.whnfIO $ do let (T3 _ join1 _) = mainLineBlocks !! 5 void $ playLine pdb bhdb 5 join1 pactQueue nonceCounter - doubleForkingBench = withResources rdb 10 Quiet DontCompact PersistIntraBlockWrites + doubleForkingBench = withResources rdb 10 Quiet PersistIntraBlockWrites $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ -> C.bench "doubleForkingBench" $ C.whnfIO $ do let (T3 _ join1 _) = mainLineBlocks !! 5 @@ -173,23 +118,6 @@ bench rdb = C.bgroup "PactService" $ void $ playLine pdb bhdb forkLength1 join1 pactQueue nonceCounter void $ playLine pdb bhdb forkLength2 join1 pactQueue nonceCounter - oneBlock :: BenchConfig -> Int -> C.Benchmark - oneBlock cfg txCount = withResources rdb cfg.numPriorBlocks Error cfg.compact cfg.persistIntraBlockWrites go - where - go mainLineBlocks _pdb _bhdb _nonceCounter pactQueue txsPerBlock = do - C.bench name $ C.whnfIO $ do - writeIORef txsPerBlock txCount - let (T3 _ join1 _) = last mainLineBlocks - createBlock cfg.validate (ParentHeader join1) (Nonce 1234) pactQueue - name = "block-new [" - ++ List.intercalate "," - [ "txCount=" ++ show txCount - , "validate=" ++ show (cfg.validate == DoValidate) - , "compact=" ++ show (cfg.compact == DoCompact) - , "persist=" ++ show cfg.persistIntraBlockWrites - ] - ++ "]" - -- -------------------------------------------------------------------------- -- -- Benchmark Function @@ -228,37 +156,34 @@ mineBlock -> PactQueue -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) mineBlock parent nonce pdb bhdb pact = do - r@(T3 _ newHeader payload) <- createBlock DoValidate parent nonce pact + r@(T3 _ newHeader payload) <- createBlock parent nonce pact addNewPayload pdb (succ (view blockHeight (_parentHeader parent))) payload -- NOTE: this doesn't validate the block header, which is fine in this test case unsafeInsertBlockHeaderDb bhdb newHeader return r createBlock - :: Validate - -> ParentHeader + :: ParentHeader -> Nonce -> PactQueue -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) -createBlock validate parent nonce pact = do +createBlock parent nonce pact = do + -- assemble block without nonce and timestamp - -- assemble block without nonce and timestamp + bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill parent pact + let payload = forAnyPactVersion finalizeBlock bip - bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill parent pact - let payload = forAnyPactVersion finalizeBlock bip - - let creationTime = add second $ view blockCreationTime $ _parentHeader parent - let bh = newBlockHeader + let creationTime = add second $ view blockCreationTime $ _parentHeader parent + let bh = newBlockHeader mempty (_payloadWithOutputsPayloadHash payload) nonce creationTime parent - when (validate == DoValidate) $ do - void $ validateBlock bh (CheckablePayloadWithOutputs payload) pact + void $ validateBlock bh (CheckablePayloadWithOutputs payload) pact - return $ T3 parent bh payload + return $ T3 parent bh payload -- -------------------------------------------------------------------------- -- -- Benchmark Resources @@ -288,11 +213,10 @@ withResources :: () => RocksDb -> Word64 -> LogLevel - -> Compact -> IntraBlockPersistence -> RunPactService -> C.Benchmark -withResources rdb trunkLength logLevel compact p f = C.envWithCleanup create destroy unwrap +withResources rdb trunkLength logLevel p f = C.envWithCleanup create destroy unwrap where unwrap ~(NoopNFData (Resources {..})) = @@ -306,29 +230,11 @@ withResources rdb trunkLength logLevel compact p f = C.envWithCleanup create des txPerBlock <- newIORef 10 mp <- testMemPoolAccess txPerBlock coinAccounts (sqlEnv, pactService, mainTrunkBlocks) <- do - srcSqlEnv <- openSQLiteConnection "" {- temporary SQLite db -} chainwebBenchPragmas - srcPactService <- - startPact testVer logger blockHeaderDb payloadDb mp srcSqlEnv + sqlEnv <- openSQLiteConnection "" {- temporary SQLite db -} chainwebBenchPragmas + pactService <- + startPact testVer logger blockHeaderDb payloadDb mp sqlEnv mainTrunkBlocks <- - playLine payloadDb blockHeaderDb trunkLength genesisBlock (snd srcPactService) nonceCounter - - (sqlEnv, pactService) <- do - if compact == DoCompact - then do - targetSqlEnv <- openSQLiteConnection "" {- temporary SQLite db -} chainwebBenchPragmas - C.withDefaultLogger Error $ \lgr -> do - C.compactPactState lgr C.defaultRetainment (BlockHeight trunkLength) srcSqlEnv targetSqlEnv - targetPactService <- - startPact testVer logger blockHeaderDb payloadDb mp targetSqlEnv - - -- Stop the previous pact service/close the sqlite connection - stopPact srcPactService - stopSqliteDb srcSqlEnv - - pure (targetSqlEnv, targetPactService) - else do - pure (srcSqlEnv, srcPactService) - + playLine payloadDb blockHeaderDb trunkLength genesisBlock (snd pactService) nonceCounter pure (sqlEnv, pactService, mainTrunkBlocks) return $ NoopNFData $ Resources {..} diff --git a/bench/Chainweb/Pact/Backend/PactService.hs b/bench/Chainweb/Pact/Backend/PactService.hs new file mode 100644 index 0000000000..9c163335e1 --- /dev/null +++ b/bench/Chainweb/Pact/Backend/PactService.hs @@ -0,0 +1,255 @@ +{-# language + BangPatterns + , DataKinds + , FlexibleContexts + , ImpredicativeTypes + , ImportQualifiedPost + , LambdaCase + , NumericUnderscores + , OverloadedRecordDot + , OverloadedStrings + , PackageImports + , ScopedTypeVariables + , TypeApplications + , TemplateHaskell + , RecordWildCards + , TupleSections +#-} + +{-# options_ghc -fno-warn-orphans #-} + +module Chainweb.Pact.Backend.PactService + ( bench + ) where + +import Chainweb.BlockHeader +import Chainweb.ChainId +import Chainweb.Chainweb +import Chainweb.Graph (singletonChainGraph) +import Chainweb.Mempool.Consensus +import Chainweb.Mempool.InMem +import Chainweb.Mempool.Mempool (InsertType (..), MempoolBackend (..)) +import Chainweb.Miner.Pact +import Chainweb.Pact.Backend.Types (SQLiteEnv) +import Chainweb.Pact.Backend.Utils (openSQLiteConnection, closeSQLiteConnection, chainwebPragmas) +import Chainweb.Pact.PactService +import Chainweb.Pact.PactService.Pact4.ExecBlock () +import Chainweb.Pact.Service.BlockValidation +import Chainweb.Pact.Service.PactInProcApi +import Chainweb.Pact.Service.PactQueue +import Chainweb.Pact.Types +import Chainweb.Pact4.Transaction qualified as Pact4 +import Chainweb.Payload +import Chainweb.Storage.Table.RocksDB +import Chainweb.Test.Cut.TestBlockDb (TestBlockDb(..), addTestBlockDb, getParentTestBlockDb, mkTestBlockDbIO) +import Chainweb.Test.Pact5.CmdBuilder +import Chainweb.Test.Pact5.Utils hiding (withTempSQLiteResource) +import Chainweb.Test.TestVersions +import Chainweb.Test.Utils +import Chainweb.Time +import Chainweb.Utils +import Chainweb.Utils.Bench +import Chainweb.Version +import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) +import Chainweb.WebPactExecutionService +import Control.Concurrent hiding (throwTo) +import Control.Concurrent.Async (forConcurrently) +import Control.DeepSeq +import Control.Exception (AsyncException (..)) +import Control.Exception.Safe +import Control.Lens hiding (only) +import Control.Monad +import Control.Monad.IO.Class +import Criterion.Main qualified as C +import Data.ByteString.Lazy qualified as LBS +import Data.Decimal +import Data.HashSet qualified as HashSet +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Pact.Core.Capabilities +import Pact.Core.Gas.Types +import Pact.Core.Names +import Pact.Core.PactValue +import Pact.Types.Gas qualified as Pact4 +import PropertyMatchers qualified as P +import Test.Tasty.HUnit (assertEqual) +import Text.Printf (printf) + +bench :: RocksDb -> C.Benchmark +bench rdb = do + C.bgroup "PactService" + [ C.bgroup "Pact4" + [ C.bench "1 tx" $ oneBlock pact4Version rdb 1 + , C.bench "10 txs" $ oneBlock pact4Version rdb 10 + , C.bench "20 txs" $ oneBlock pact4Version rdb 20 + , C.bench "30 txs" $ oneBlock pact4Version rdb 30 + , C.bench "40 txs" $ oneBlock pact4Version rdb 40 + , C.bench "50 txs" $ oneBlock pact4Version rdb 50 + , C.bench "60 txs" $ oneBlock pact4Version rdb 60 + , C.bench "70 txs" $ oneBlock pact4Version rdb 70 + , C.bench "80 txs" $ oneBlock pact4Version rdb 80 + , C.bench "90 txs" $ oneBlock pact4Version rdb 90 + , C.bench "100 txs" $ oneBlock pact4Version rdb 100 + ] + , C.bgroup "Pact5" + [ C.bench "1 tx" $ oneBlock pact5Version rdb 1 + , C.bench "10 txs" $ oneBlock pact5Version rdb 10 + , C.bench "20 txs" $ oneBlock pact5Version rdb 20 + , C.bench "30 txs" $ oneBlock pact5Version rdb 30 + , C.bench "40 txs" $ oneBlock pact5Version rdb 40 + , C.bench "50 txs" $ oneBlock pact5Version rdb 50 + , C.bench "60 txs" $ oneBlock pact5Version rdb 60 + , C.bench "70 txs" $ oneBlock pact5Version rdb 70 + , C.bench "80 txs" $ oneBlock pact5Version rdb 80 + , C.bench "90 txs" $ oneBlock pact5Version rdb 90 + , C.bench "100 txs" $ oneBlock pact5Version rdb 100 + ] + ] + +data Fixture = Fixture + { _chainwebVersion :: !ChainwebVersion + , _fixtureBlockDb :: !TestBlockDb + , _fixtureBlockDbRocksDb :: !RocksDb + , _fixtureMempools :: !(ChainMap (MempoolBackend Pact4.UnparsedTransaction)) + , _fixturePactQueues :: !(ChainMap PactQueue) + , _fixturePactServiceThreads :: !(ChainMap ThreadId) + , _fixturePactServiceSqls :: !(ChainMap SQLiteEnv) + } + +instance NFData Fixture where + rnf !_ = () + +createFixture :: ChainwebVersion -> RocksDb -> PactServiceConfig -> IO Fixture +createFixture v rdb pactServiceConfig = do + T2 tdb tdbRdb <- mkTestBlockDbIO v rdb + logger <- testLogger + + perChain <- iforM (HashSet.toMap (chainIds v)) $ \chain () -> do + sql <- openSQLiteConnection "" chainwebPragmas + bhdb <- liftIO $ getWebBlockHeaderDb (_bdbWebBlockHeaderDb tdb) chain + pactQueue <- liftIO $ newPactQueue 2_000 + pactExecutionServiceVar <- liftIO $ newMVar (mkPactExecutionService pactQueue) + let mempoolCfg = validatingMempoolConfig chain v (Pact4.GasLimit 150_000) (Pact4.GasPrice 1e-8) pactExecutionServiceVar + mempool <- liftIO $ startInMemoryMempoolTest mempoolCfg + mempoolConsensus <- liftIO $ mkMempoolConsensus mempool bhdb (Just (_bdbPayloadDb tdb)) + let mempoolAccess = pactMemPoolAccess mempoolConsensus logger + tid <- forkIO $ runPactService v chain logger Nothing pactQueue mempoolAccess bhdb (_bdbPayloadDb tdb) sql pactServiceConfig + return (mempool, pactQueue, tid, sql) + + let fixture = Fixture + { _chainwebVersion = v + , _fixtureBlockDb = tdb + , _fixtureBlockDbRocksDb = tdbRdb + , _fixtureMempools = OnChains $ view _1 <$> perChain + , _fixturePactQueues = OnChains $ view _2 <$> perChain + , _fixturePactServiceThreads = OnChains $ view _3 <$> perChain + , _fixturePactServiceSqls = OnChains $ view _4 <$> perChain + } + -- The mempool expires txs based on current time, but newBlock expires txs based on parent creation time. + -- So by running an empty block with the creationTime set to the current time, we get these goals to align + -- for future blocks we run. + _ <- liftIO $ advanceAllChains fixture $ onChains [] + + return fixture + +destroyFixture :: Fixture -> IO () +destroyFixture fx = do + forM_ fx._fixturePactServiceThreads $ \tid -> do + throwTo tid ThreadKilled + forM_ fx._fixturePactServiceSqls $ \sql -> do + closeSQLiteConnection sql + deleteNamespaceRocksDb fx._fixtureBlockDbRocksDb + +oneBlock :: ChainwebVersion -> RocksDb -> Word -> C.Benchmarkable +oneBlock v rdb numTxs = + let cid = unsafeChainId 0 + cfg = testPactServiceConfig + + setupEnv _ = do + fx <- createFixture v rdb cfg + return fx + + cleanupEnv _ fx = do + destroyFixture fx + in + C.perBatchEnvWithCleanup setupEnv cleanupEnv $ \ ~fx -> do + advanceAllChains fx $ onChain cid $ \ph pactQueue mempool -> do + mempoolClear mempool + txs <- forM [1..numTxs] $ \_ -> do + buildCwCmd v (transferCmd cid 1.0) + mempoolInsertPact5 (fx._fixtureMempools ^?! atChain cid) UncheckedInsert txs + + bip <- throwIfNoHistory =<< + newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue + let block = forAnyPactVersion finalizeBlock bip + fromIntegral @_ @Word (Vector.length (_payloadWithOutputsTransactions block)) + & P.equals numTxs + return block + +-- this mines a block on *all chains*. if you don't specify a payload on a chain, +-- it adds empty blocks! +advanceAllChains :: () + => Fixture + -> ChainMap (BlockHeader -> PactQueue -> MempoolBackend Pact4.UnparsedTransaction -> IO PayloadWithOutputs) + -> IO (ChainMap (Vector TestPact5CommandResult)) +advanceAllChains Fixture{..} blocks = do + commandResults <- + forConcurrently (HashSet.toList (chainIds _chainwebVersion)) $ \c -> do + ph <- getParentTestBlockDb _fixtureBlockDb c + creationTime <- getCurrentTimeIntegral + let pactQueue = _fixturePactQueues ^?! atChain c + let mempool = _fixtureMempools ^?! atChain c + let makeEmptyBlock p _ _ = do + bip <- throwIfNoHistory =<< + newBlock noMiner NewBlockEmpty (ParentHeader p) pactQueue + return $! forAnyPactVersion finalizeBlock bip + + payload <- fromMaybe makeEmptyBlock (blocks ^? atChain c) ph pactQueue mempool + added <- addTestBlockDb _fixtureBlockDb + (succ $ view blockHeight ph) + (Nonce 0) + (\_ _ -> creationTime) + c + payload + when (not added) $ + error "failed to mine block" + ph' <- getParentTestBlockDb _fixtureBlockDb c + payload' <- validateBlock ph' (CheckablePayloadWithOutputs payload) pactQueue + assertEqual "payloads must not be altered by validateBlock" payload payload' + commandResults :: Vector TestPact5CommandResult + <- forM + (_payloadWithOutputsTransactions payload') + (decodeOrThrow' + . LBS.fromStrict + . _transactionOutputBytes + . snd) + -- assert on the command results + return (c, commandResults) + + return (onChains commandResults) + +transferCmd :: ChainId -> Decimal -> CmdBuilder +transferCmd chain transferAmount = (defaultCmd chain) + { _cbRPC = mkExec' $ + "(coin.transfer \"sender00\" \"sender01\" " <> + -- if the number doesn't end with a decimal part, even if it's zero, Pact will + -- throw an error + T.pack (printf "%.4f" (realToFrac transferAmount :: Double)) <> + ")" + , _cbSigners = + [ mkEd25519Signer' sender00 + [ CapToken (QualifiedName "GAS" (ModuleName "coin" Nothing)) [] + , CapToken (QualifiedName "TRANSFER" coinModuleName) [PString "sender00", PString "sender01", PDecimal transferAmount] + ] + ] + , _cbGasPrice = GasPrice 0.000_000_000_001 + , _cbGasLimit = GasLimit (Gas 1000) + } + +pact4Version :: ChainwebVersion +pact4Version = instantCpmTestVersion singletonChainGraph + +pact5Version :: ChainwebVersion +pact5Version = pact5InstantCpmTestVersion singletonChainGraph diff --git a/bench/Chainweb/Utils/Bench.hs b/bench/Chainweb/Utils/Bench.hs index 17afb9411e..9abe6ca787 100644 --- a/bench/Chainweb/Utils/Bench.hs +++ b/bench/Chainweb/Utils/Bench.hs @@ -1,16 +1,92 @@ +{-# language + BangPatterns + , DerivingStrategies + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , StandaloneDeriving +#-} + +{-# options_ghc -fno-warn-orphans #-} + module Chainweb.Utils.Bench - ( - NoopNFData(..) + ( NoopNFData(..) + , testLogger ) where -import Control.DeepSeq - +import Chainweb.Logger +import Pact.Core.Errors +import Chainweb.Test.Cut.TestBlockDb (TestBlockDb) +import Chainweb.Test.Pact5.Utils (getTestLogLevel) +import Chainweb.Test.Utils () +import Database.SQLite3.Direct (Database(..)) +import Chainweb.WebBlockHeaderDB (WebBlockHeaderDb) +import Chainweb.Pact.Types (PactServiceEnv) +import Control.DeepSeq (NFData(..)) +import Chainweb.Mempool.Mempool (MempoolBackend) +import Chainweb.Pact.Service.PactQueue (PactQueue) +import Control.Monad.IO.Class (liftIO) +import Data.Text.IO qualified as Text +-- | Create a 'GenericLogger' by inspecting the +-- 'CHAINWEB_TEST_LOG_LEVEL' environment variable. +testLogger :: IO GenericLogger +testLogger = do + logLevel <- liftIO getTestLogLevel + pure $ genericLogger logLevel Text.putStrLn --- | Newtype to provide a noop NFData instance. --- Intended for use in criterion's 'envWithCleanup' --- which wants environment values to be NFData. +-- | Newtype to provide a noop 'NFData' instance. +-- +-- Intended for use in criterion's 'envWithCleanup' +-- which wants environment values to be 'NFData'. newtype NoopNFData a = NoopNFData a - deriving (Show) + deriving stock (Show) + instance NFData (NoopNFData a) where rnf _ = () + +-- Orphan Instances -- + +deriving newtype instance NFData Database + +instance NFData (PactServiceEnv logger tbl) where + rnf !_ = () + +instance NFData WebBlockHeaderDb where + rnf !_ = () + +instance NFData TestBlockDb where + rnf !_ = () + +instance NFData (MempoolBackend a) where + rnf !_ = () + +instance NFData PactQueue where + rnf !_ = () + +instance (NFData info) => NFData (PactErrorCompat info) where + rnf = \case + PEPact5Error errorCode -> rnf errorCode + PELegacyError legacyError -> rnf legacyError + +instance (NFData info) => NFData (PactErrorCode info) where + rnf (PactErrorCode a b c) = rnf a `seq` rnf b `seq` rnf c + +deriving newtype instance NFData ErrorCode + +instance NFData (BoundedText k) where + rnf !_ = () + +instance NFData LegacyPactErrorType where + rnf !_ = () + +instance NFData LegacyPactError where + rnf (LegacyPactError a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + +instance (NFData info) => NFData (LocatedErrorInfo info) where + rnf (LocatedErrorInfo a b) = rnf a `seq` rnf b + +instance NFData PactErrorOrigin where + rnf = \case + TopLevelErrorOrigin -> () + FunctionErrorOrigin fqn -> rnf fqn diff --git a/chainweb.cabal b/chainweb.cabal index 41f183d583..fa89a30cfb 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -862,8 +862,10 @@ 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.Pact.Backend.PactService Chainweb.Utils.Bench JSONEncoding @@ -883,14 +885,21 @@ benchmark bench , containers >= 0.5 , criterion , deepseq >= 1.4 + , direct-sqlite , exceptions >= 0.8 , file-embed >= 0.0 , lens >= 4.17 , loglevel >= 0.1 , mtl >= 2.3 , pact + , pact-tng + , pact-tng:pact-request-api + , property-matchers , random >= 1.2 + , safe-exceptions , streaming + , tasty-hunit , text >= 2.0 + , unordered-containers , vector >= 0.12.2 , yaml >= 0.11 diff --git a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs index e09f463192..f7689e452c 100644 --- a/test/lib/Chainweb/Test/Cut/TestBlockDb.hs +++ b/test/lib/Chainweb/Test/Cut/TestBlockDb.hs @@ -11,6 +11,7 @@ module Chainweb.Test.Cut.TestBlockDb ( TestBlockDb(..) , mkTestBlockDb + , mkTestBlockDbIO , addTestBlockDb , getParentTestBlockDb , getParentBlockTestBlockDb @@ -66,6 +67,19 @@ mkTestBlockDb cv rdb = do initCut <- newMVar $ genesisCut cv return $! TestBlockDb wdb pdb initCut +-- | Initialize TestBlockDb in 'IO'. This is discouraged in most test environments. +-- Use this only when you cannot use 'ResourceT'. +-- +-- Take care to call 'deleteNamespaceRocksDb' on the 'RocksDb' that this returns +-- in between test runs. +mkTestBlockDbIO :: ChainwebVersion -> RocksDb -> IO (T2 TestBlockDb RocksDb) +mkTestBlockDbIO v rdb = do + testRdb <- testRocksDb "mkTestBlockDbIO" rdb + wdb <- initWebBlockHeaderDb testRdb v + let pdb = newPayloadDb testRdb + initializePayloadDb v pdb + initCut <- newMVar $ genesisCut v + return $! T2 (TestBlockDb wdb pdb initCut) testRdb -- | Add a block. --