wip benching

Change-Id: Ic7ad4dd33a4df801c2c8e8853ab5e45b08b51db8

bench/Bench.hs

@@ -10,21 +10,25 @@ 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
 
 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
     ]

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

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)
 

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

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

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 #-}

src/Chainweb/Logger.hs

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

src/Chainweb/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