pact5 preliminary benchmarks

Change-Id: I241132deae7e66619674e1c08db668a1d3500ab8

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 <[email protected]>
 -- 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
     ]

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