Add CoreModuleCache

chainweb.cabal

@@ -314,6 +314,7 @@ library
         , Chainweb.Pact.Transactions.Mainnet9Transactions
         , Chainweb.Pact.Transactions.MainnetKADTransactions
         , Chainweb.Pact.Transactions.OtherTransactions
+        , Chainweb.Pact.Conversions
         , Chainweb.Pact.Types
         , Chainweb.Pact.Utils
         , Chainweb.Pact.Validations

src/Chainweb/Pact/Conversions.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Chainweb.Pact.Conversions where
+
+import Data.Coerce (coerce)
+
+import Pact.Interpreter (PactDbEnv)
+import qualified Pact.JSON.Encode as J
+import qualified Pact.JSON.Legacy.HashMap as LHM
+import Pact.Parse (ParsedDecimal)
+import Pact.Types.ChainId (NetworkId)
+import Pact.Types.ChainMeta
+import Pact.Types.Command
+import Pact.Types.Gas
+import Pact.Types.Names
+import Pact.Types.Persistence (ExecutionMode, TxLogJson)
+import Pact.Types.Pretty (viaShow)
+import Pact.Types.Runtime (ExecutionConfig(..), ModuleData(..), PactWarning, PactError(..), PactErrorType(..))
+import Pact.Types.SPV
+import Pact.Types.Term
+import qualified Pact.Types.Logger as P
+
+import qualified Pact.Core.Evaluate as PCore
+import qualified Pact.Core.Compile as PCore
+import qualified Pact.Core.Capabilities as PCore
+import qualified Pact.Core.Info as PCore
+import qualified Pact.Core.Names as PCore
+import qualified Pact.Core.Namespace as PCore
+import qualified Pact.Core.Persistence as PCore
+import qualified Pact.Core.Pretty as PCore
+import qualified Pact.Core.Gas as PCore
+import qualified Pact.Core.Hash as PCore
+import qualified Pact.Core.Errors as PCore
+import qualified Pact.Core.Debug as PCore
+import qualified Pact.Core.Serialise.LegacyPact as PCore
+import qualified Pact.Core.PactValue as PCore
+import qualified Pact.Core.Environment as PCore
+import qualified Pact.Core.IR.Term as PCore
+import qualified Pact.Core.Builtin as PCore
+import qualified Pact.Core.Syntax.ParseTree as PCore
+import qualified Pact.Core.DefPacts.Types as PCore
+import qualified Pact.Core.Scheme as PCore
+
+convertModuleName :: ModuleName -> PCore.ModuleName
+convertModuleName ModuleName{..} =
+  PCore.ModuleName
+    { PCore._mnName = _mnName
+    , PCore._mnNamespace = fmap coerce _mnNamespace
+    }
+

src/Chainweb/Pact/PactService.hs

@@ -428,17 +428,17 @@ attemptBuyGas
     -> Vector (Either InsertError ChainwebTransaction)
     -> PactServiceM logger tbl (Vector (Either InsertError ChainwebTransaction))
 attemptBuyGas miner (PactDbEnv' (dbEnv,coreDb)) txs = localLabel ("transaction", "attemptBuyGas") $ do
-        mc <- getInitCache
+        (mc, cmc) <- getInitCache
         l <- view psLogger
-        V.fromList . toList . sfst <$> V.foldM (f l) (T2 mempty mc) txs
+        V.fromList . toList . sfst <$> V.foldM (f l) (T2 mempty (mc, cmc)) txs
   where
     f :: logger
-      -> T2 (DL.DList (Either InsertError ChainwebTransaction)) ModuleCache
+      -> T2 (DL.DList (Either InsertError ChainwebTransaction)) (ModuleCache, CoreModuleCache)
       -> Either InsertError ChainwebTransaction
-      -> PactServiceM logger tbl (T2 (DL.DList (Either InsertError ChainwebTransaction)) ModuleCache)
-    f l (T2 dl mcache) cmd = do
-        T2 mcache' !res <- runBuyGas l dbEnv coreDb mcache cmd
-        pure $! T2 (DL.snoc dl res) mcache'
+      -> PactServiceM logger tbl (T2 (DL.DList (Either InsertError ChainwebTransaction)) (ModuleCache, CoreModuleCache))
+    f l (T2 dl (mcache, cmcache)) cmd = do
+        T3 mcache' cmcache' !res <- runBuyGas l dbEnv coreDb (mcache, cmcache) cmd
+        pure $! T2 (DL.snoc dl res) (mcache', cmcache')
 
     createGasEnv
         :: logger
@@ -464,16 +464,17 @@ attemptBuyGas miner (PactDbEnv' (dbEnv,coreDb)) txs = localLabel ("transaction",
         :: logger
         -> P.PactDbEnv a
         -> CoreDb
-        -> ModuleCache
+        -> (ModuleCache, CoreModuleCache)
         -> Either InsertError ChainwebTransaction
-        -> PactServiceM logger tbl (T2 ModuleCache (Either InsertError ChainwebTransaction))
-    runBuyGas _l _db cdb mcache l@Left {} = return (T2 mcache l)
-    runBuyGas l db cdb mcache (Right tx) = do
+        -> PactServiceM logger tbl (T3 ModuleCache CoreModuleCache (Either InsertError ChainwebTransaction))
+    runBuyGas _l _db cdb (mcache, cmcache) l@Left {} = return (T3 mcache cmcache l)
+    runBuyGas l db cdb (mcache, cmcache) (Right tx) = do
         let cmd = payloadObj <$> tx
             gasPrice = view cmdGasPrice cmd
             gasLimit = fromIntegral $ view cmdGasLimit cmd
             txst = TransactionState
                 { _txCache = mcache
+                , _txCoreCache = cmcache
                 , _txLogs = mempty
                 , _txGasUsed = 0
                 , _txGasId = Nothing
@@ -489,8 +490,8 @@ attemptBuyGas miner (PactDbEnv' (dbEnv,coreDb)) txs = localLabel ("transaction",
           $! buyGas False cmd miner
 
         case cr of
-            Left err -> return (T2 mcache (Left (InsertErrorBuyGas (T.pack $ show err))))
-            Right t -> return (T2 (_txCache t) (Right tx))
+            Left err -> return (T3 mcache cmcache (Left (InsertErrorBuyGas (T.pack $ show err))))
+            Right t -> return (T3 (_txCache t) (_txCoreCache t) (Right tx))
 
 -- | Note: The BlockHeader param here is the PARENT HEADER of the new
 -- block-to-be
@@ -743,7 +744,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ withDiscarde
             assertLocalMetadata cmd ctx sigVerify >>= \case
               Right{} -> do
                 let initialGas = initialGasOf $ P._cmdPayload cwtx
-                T3 cr _mc warns <- liftIO $ applyCmd
+                T4 cr _mc _cmc warns <- liftIO $ applyCmd
                   _psVersion _psLogger _psGasLogger pdbenv
                   noMiner gasModel ctx spv cmd
                   initialGas mc ApplyLocal

src/Chainweb/Pact/PactService/ExecBlock.hs

@@ -161,7 +161,8 @@ execBlock currHeader plData pdbenv = do
       fromIntegral <$> maxBlockGasLimit v (_blockHeight currHeader)
 
     logInitCache = do
-      mc <- fmap (fmap instr . _getModuleCache) <$> use psInitCache
+      initCache <- use psInitCache
+      let mc = fmap (\(mc, _) -> fmap instr $ _getModuleCache mc) initCache
       logDebug $ "execBlock: initCache: " <> sshow mc
 
     instr (md,_) = preview (P._MDModule . P.mHash) $ P._mdModule md
@@ -305,17 +306,17 @@ execTransactions
     -> Maybe Micros
     -> PactServiceM logger tbl (Transactions (Either GasPurchaseFailure (P.CommandResult [P.TxLogJson])))
 execTransactions isGenesis miner ctxs enfCBFail usePrecomp (PactDbEnv' pactdbenv) gasLimit timeLimit = do
-    mc <- getCache
+    (mc, cmc) <- getCache
 
-    coinOut <- runCoinbase isGenesis pactdbenv miner enfCBFail usePrecomp mc
-    txOuts <- applyPactCmds isGenesis pactdbenv ctxs miner mc gasLimit timeLimit
+    coinOut <- runCoinbase isGenesis pactdbenv miner enfCBFail usePrecomp (mc, cmc)
+    txOuts <- applyPactCmds isGenesis pactdbenv ctxs miner (mc, cmc) gasLimit timeLimit
     return $! Transactions (V.zip ctxs txOuts) coinOut
   where
     getCache = get >>= \PactServiceState{..} -> do
       let pbh = _blockHeight . _parentHeader
       case Map.lookupLE (pbh _psParentHeader) _psInitCache of
         Nothing -> if isGenesis
-          then return mempty
+          then return (mempty, mempty)
           else do
             l <- asks _psLogger
             txCtx <- getTxContext def
@@ -344,10 +345,10 @@ runCoinbase
     -> Miner
     -> EnforceCoinbaseFailure
     -> CoinbaseUsePrecompiled
-    -> ModuleCache
+    -> (ModuleCache, CoreModuleCache)
     -> PactServiceM logger tbl (P.CommandResult [P.TxLogJson])
 runCoinbase True _ _ _ _ _ = return noCoinbase
-runCoinbase False dbEnv miner enfCBFail usePrecomp mc = do
+runCoinbase False dbEnv miner enfCBFail usePrecomp (mc, cmc) = do
     logger <- view psLogger
     rs <- view psMinerRewards
     v <- view chainwebVersion
@@ -357,7 +358,7 @@ runCoinbase False dbEnv miner enfCBFail usePrecomp mc = do
 
     reward <- liftIO $! minerReward v rs bh
 
-    (T2 cr upgradedCacheM) <- liftIO $ applyCoinbase v logger dbEnv miner reward txCtx enfCBFail usePrecomp mc
+    (T2 cr upgradedCacheM) <- liftIO $ applyCoinbase v logger dbEnv miner reward txCtx enfCBFail usePrecomp (mc, cmc)
     mapM_ upgradeInitCache upgradedCacheM
     debugResult "runCoinbase" (P.crLogs %~ fmap J.Array $ cr)
     return $! cr
@@ -378,14 +379,14 @@ applyPactCmds
     -> (P.PactDbEnv p, CoreDb)
     -> Vector ChainwebTransaction
     -> Miner
-    -> ModuleCache
+    -> (ModuleCache, CoreModuleCache)
     -> Maybe P.Gas
     -> Maybe Micros
     -> PactServiceM logger tbl (Vector (Either GasPurchaseFailure (P.CommandResult [P.TxLogJson])))
-applyPactCmds isGenesis env cmds miner mc blockGas txTimeLimit = do
+applyPactCmds isGenesis env cmds miner (mc, cmc) blockGas txTimeLimit = do
     let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to P._crGas) txs
     txs <- tracePactServiceM' "applyPactCmds" () txsGas $
-      evalStateT (V.mapM (applyPactCmd isGenesis env miner txTimeLimit) cmds) (T2 mc blockGas)
+      evalStateT (V.mapM (applyPactCmd isGenesis env miner txTimeLimit) cmds) (T3 mc cmc blockGas)
     return txs
 
 applyPactCmd
@@ -396,16 +397,16 @@ applyPactCmd
   -> Maybe Micros
   -> ChainwebTransaction
   -> StateT
-      (T2 ModuleCache (Maybe P.Gas))
+      (T3 ModuleCache CoreModuleCache (Maybe P.Gas))
       (PactServiceM logger tbl)
       (Either GasPurchaseFailure (P.CommandResult [P.TxLogJson]))
-applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do
+applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache maybeBlockGasRemaining) -> do
   logger <- view psLogger
   gasLogger <- view psGasLogger
   gasModel <- view psGasModel
   v <- view psVersion
   let
-    onBuyGasFailure (BuyGasFailure f) = pure $! (Left f, T2 mcache maybeBlockGasRemaining)
+    onBuyGasFailure (BuyGasFailure f) = pure $! (Left f, T3 mcache cmcache maybeBlockGasRemaining)
     onBuyGasFailure e = throwM e
     requestedTxGasLimit = view cmdGasLimit (payloadObj <$> cmd)
     -- notice that we add 1 to the remaining block gas here, to distinguish the
@@ -421,7 +422,7 @@ applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlo
       set cmdGasLimit newTxGasLimit (payloadObj <$> cmd)
     initialGas = initialGasOf (P._cmdPayload cmd)
   handle onBuyGasFailure $ do
-    T2 result mcache' <- do
+    T2 result (mcache', cmcache') <- do
       txCtx <- getTxContext (publicMetaOf gasLimitedCmd)
       if isGenesis
       then liftIO $! applyGenesisCmd logger env P.noSPVSupport txCtx gasLimitedCmd
@@ -433,14 +434,14 @@ applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlo
             Nothing -> id
             Just limit ->
                maybe (throwM timeoutError) return <=< timeout (fromIntegral limit)
-        let txGas (T3 r _ _) = fromIntegral $ P._crGas r
-        T3 r c _warns <-
+        let txGas (T4 r _ _ _) = fromIntegral $ P._crGas r
+        T4 r c cc _warns <-
           tracePactServiceM' "applyCmd" (J.toJsonViaEncode (P._cmdHash cmd)) txGas $
-            liftIO $ txTimeout $ applyCmd v logger gasLogger env miner (gasModel txCtx) txCtx spv gasLimitedCmd initialGas mcache ApplySend
-        pure $ T2 r c
+            liftIO $ txTimeout $ applyCmd v logger gasLogger env miner (gasModel txCtx) txCtx spv gasLimitedCmd initialGas (mcache, cmcache) ApplySend
+        pure $ T2 r (c, cc)
 
     if isGenesis
-    then updateInitCache mcache'
+    then updateInitCache (mcache', cmcache')
     else debugResult "applyPactCmd" (P.crLogs %~ fmap J.Array $ result)
 
     cp <- getCheckpointer
@@ -457,7 +458,7 @@ applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlo
           throwM $ BlockGasLimitExceeded (blockGasRemaining - fromIntegral requestedTxGasLimit)
       Nothing -> return ()
     let maybeBlockGasRemaining' = (\g -> g - P._crGas result) <$> maybeBlockGasRemaining
-    pure (Right result, T2 mcache' maybeBlockGasRemaining')
+    pure (Right result, T3 mcache' cmcache' maybeBlockGasRemaining')
 
 toHashCommandResult :: P.CommandResult [P.TxLogJson] -> P.CommandResult P.Hash
 toHashCommandResult = over (P.crLogs . _Just) $ P.pactHash . P.encodeTxLogJsonArray