Implement memoization of Plutus script context computation

Author: lehins

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.13.0.0
 
+* Add `TxInfoResult` data family, `mkTxInfoResult` and `lookupTxInfoResult` to `EraPlutusContext`
+* Add `lookupTxInfoResultImpossible` helper
+* Add `TxInfoResult era` parameter to `toPlutusWithContext` and `mkPlutusWithContext`
 * Made the fields of predicate failures and environments lazy
 * Add `MemPack` instance for `Addr28Extra`, `DataHash32`, `AlonzoTxOut` and `PlutusScript AlonzoEra`
 * Deprecate `hashAlonzoTxAuxData`

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs

@@ -7,12 +7,16 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
+-- Recursive definition constraints of `EraPlutusContext` and `EraPlutusTxInfo` lead to a wrongful
+-- redundant constraint warning in the definition of `lookupTxInfoResult`
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Cardano.Ledger.Alonzo.Plutus.Context (
   LedgerTxInfo (..),
   EraPlutusTxInfo (..),
   EraPlutusContext (..),
   toPlutusWithContext,
+  lookupTxInfoResultImpossible,
 
   -- * Language dependent translation
   PlutusTxInfo,
@@ -45,15 +49,17 @@ import Cardano.Ledger.Plutus (
   PlutusRunnable,
   PlutusScriptContext,
   PlutusWithContext (..),
+  SLanguage (..),
+  isLanguage,
  )
 import Cardano.Ledger.UTxO (UTxO (..))
 import Cardano.Slotting.EpochInfo (EpochInfo)
 import Cardano.Slotting.Time (SystemStart)
 import Control.DeepSeq (NFData)
 import Data.Aeson (ToJSON)
 import Data.Kind (Type)
-import Data.Proxy (Proxy (..))
 import Data.Text (Text)
+import GHC.Stack
 import NoThunks.Class (NoThunks)
 import qualified PlutusLedgerApi.V1 as PV1
 import qualified PlutusLedgerApi.V2 as PV2
@@ -109,11 +115,28 @@ class
   where
   type ContextError era = (r :: Type) | r -> era
 
+  -- | This data type family is used to memoize the results of `toPlutusTxInfo`, so the outcome can
+  -- be shared between execution of different scripts with the same language version.
+  data TxInfoResult era :: Type
+
+  -- | Construct `PlutusTxInfo` for all supported languages in this era.
+  mkTxInfoResult :: LedgerTxInfo era -> TxInfoResult era
+
+  -- | `TxInfo` for the same language can be shared between executions of every script of the same
+  -- version in a single transaction.
+  --
+  -- /Note/ - The `EraPlutusTxInfo` is here only to enforce this function is not called with an
+  -- unsupported plutus language version.
+  lookupTxInfoResult ::
+    EraPlutusTxInfo l era =>
+    SLanguage l -> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
+
   mkPlutusWithContext ::
     PlutusScript era ->
     ScriptHash ->
     PlutusPurpose AsIxItem era ->
     LedgerTxInfo era ->
+    TxInfoResult era ->
     (Data era, ExUnits) ->
     CostModel ->
     Either (ContextError era) PlutusWithContext
@@ -125,16 +148,17 @@ toPlutusWithContext ::
   ScriptHash ->
   PlutusPurpose AsIxItem era ->
   LedgerTxInfo era ->
+  TxInfoResult era ->
   (Data era, ExUnits) ->
   CostModel ->
   Either (ContextError era) PlutusWithContext
-toPlutusWithContext script scriptHash plutusPurpose lti (redeemerData, exUnits) costModel = do
-  let proxy = Proxy @l
+toPlutusWithContext script scriptHash plutusPurpose lti txInfoResult (redeemerData, exUnits) costModel = do
+  let slang = isLanguage @l
       maybeSpendingDatum =
         getSpendingDatum (ltiUTxO lti) (ltiTx lti) (hoistPlutusPurpose toAsItem plutusPurpose)
-  txInfo <- toPlutusTxInfo proxy lti
+  txInfo <- lookupTxInfoResult slang txInfoResult
   plutusArgs <-
-    toPlutusArgs proxy (ltiProtVer lti) txInfo plutusPurpose maybeSpendingDatum redeemerData
+    toPlutusArgs slang (ltiProtVer lti) txInfo plutusPurpose maybeSpendingDatum redeemerData
   pure $
     PlutusWithContext
       { pwcProtocolVersion = pvMajor (ltiProtVer lti)
@@ -145,6 +169,13 @@ toPlutusWithContext script scriptHash plutusPurpose lti (redeemerData, exUnits)
       , pwcCostModel = costModel
       }
 
+-- | Helper function to use when implementing `lookupTxInfoResult` for plutus languages that are not
+-- supported by the era.
+lookupTxInfoResultImpossible ::
+  (HasCallStack, EraPlutusTxInfo l era) => SLanguage l -> Either (ContextError era) (PlutusTxInfo l)
+lookupTxInfoResultImpossible slang =
+  error $ "Impossible: Attempt to lookup TxInfoResult for an unsupported language: " <> show slang
+
 -- =============================================
 -- Type families that specify Plutus types that are different from one version to another
 

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Evaluate.hs

@@ -169,6 +169,7 @@ collectPlutusScriptsWithContext epochInfo systemStart pp tx utxo =
         , ltiUTxO = utxo
         , ltiTx = tx
         }
+    txInfoResult = mkTxInfoResult ledgerTxInfo
 
     ScriptsProvided scriptsProvided = getScriptsProvided utxo tx
     AlonzoScriptsNeeded scriptsNeeded = getScriptsNeeded utxo (tx ^. bodyTxL)
@@ -189,6 +190,7 @@ collectPlutusScriptsWithContext epochInfo systemStart pp tx utxo =
           plutusScriptHash
           plutusPurpose
           ledgerTxInfo
+          txInfoResult
           (redeemerData, exUnits)
           costModel
 
@@ -366,6 +368,7 @@ evalTxExUnitsWithLogs pp tx utxo epochInfo systemStart = Map.mapWithKey findAndC
         , ltiUTxO = utxo
         , ltiTx = tx
         }
+    txInfoResult = mkTxInfoResult ledgerTxInfo
     maxBudget = pp ^. ppMaxTxExUnitsL
     txBody = tx ^. bodyTxL
     wits = tx ^. witsTxL
@@ -400,6 +403,7 @@ evalTxExUnitsWithLogs pp tx utxo epochInfo systemStart = Map.mapWithKey findAndC
             plutusScriptHash
             plutusPurpose
             ledgerTxInfo
+            txInfoResult
             (redeemerData, maxBudget)
             costModel
       case evaluatePlutusWithContext P.Verbose pwc of

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/TxInfo.hs

@@ -69,7 +69,12 @@ import Cardano.Ledger.Mary.Value (
   PolicyID (..),
  )
 import Cardano.Ledger.Plutus.Data (Data, getPlutusData)
-import Cardano.Ledger.Plutus.Language (Language (..), LegacyPlutusArgs (..), PlutusArgs (..))
+import Cardano.Ledger.Plutus.Language (
+  Language (..),
+  LegacyPlutusArgs (..),
+  PlutusArgs (..),
+  SLanguage (..),
+ )
 import Cardano.Ledger.Plutus.TxInfo
 import Cardano.Ledger.PoolParams (PoolParams (..))
 import Cardano.Ledger.Rules.ValidationMode (Inject (..))
@@ -157,6 +162,13 @@ toLegacyPlutusArgs proxy pv mkScriptContext scriptPurpose maybeSpendingData rede
 
 instance EraPlutusContext AlonzoEra where
   type ContextError AlonzoEra = AlonzoContextError AlonzoEra
+  newtype TxInfoResult AlonzoEra
+    = AlonzoTxInfoResult (Either (ContextError AlonzoEra) (PlutusTxInfo 'PlutusV1))
+
+  mkTxInfoResult = AlonzoTxInfoResult . toPlutusTxInfo SPlutusV1
+
+  lookupTxInfoResult SPlutusV1 (AlonzoTxInfoResult tirPlutusV1) = tirPlutusV1
+  lookupTxInfoResult slang _ = lookupTxInfoResultImpossible slang
 
   mkPlutusWithContext (AlonzoPlutusV1 p) = toPlutusWithContext (Left p)
 

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxInfo.hs

@@ -32,6 +32,8 @@ import Cardano.Ledger.Alonzo.Plutus.Context (
   EraPlutusTxInfo (..),
   LedgerTxInfo (..),
   PlutusScriptPurpose,
+  PlutusTxInfo,
+  lookupTxInfoResultImpossible,
   toPlutusWithContext,
  )
 import Cardano.Ledger.Alonzo.Plutus.TxInfo (
@@ -65,7 +67,7 @@ import Cardano.Ledger.Binary.Coders (
 import Cardano.Ledger.Mary.Value (MaryValue)
 import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, getPlutusData)
 import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
-import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..))
+import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..), SLanguage (..))
 import Cardano.Ledger.Plutus.TxInfo (
   TxOutSource (..),
   transAddr,
@@ -221,6 +223,16 @@ transTxRedeemers proxy pv tx =
 
 instance EraPlutusContext BabbageEra where
   type ContextError BabbageEra = BabbageContextError BabbageEra
+  data TxInfoResult BabbageEra
+    = BabbageTxInfoResult -- Fields must be kept lazy
+        (Either (ContextError BabbageEra) (PlutusTxInfo 'PlutusV1))
+        (Either (ContextError BabbageEra) (PlutusTxInfo 'PlutusV2))
+
+  mkTxInfoResult lti = BabbageTxInfoResult (toPlutusTxInfo SPlutusV1 lti) (toPlutusTxInfo SPlutusV2 lti)
+
+  lookupTxInfoResult SPlutusV1 (BabbageTxInfoResult tirPlutusV1 _) = tirPlutusV1
+  lookupTxInfoResult SPlutusV2 (BabbageTxInfoResult _ tirPlutusV2) = tirPlutusV2
+  lookupTxInfoResult slang _ = lookupTxInfoResultImpossible slang
 
   mkPlutusWithContext = \case
     BabbagePlutusV1 p -> toPlutusWithContext $ Left p

eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs

@@ -36,6 +36,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context (
   EraPlutusTxInfo (..),
   LedgerTxInfo (..),
   PlutusTxCert,
+  PlutusTxInfo,
   toPlutusWithContext,
  )
 import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), TxOutSource (..))
@@ -92,7 +93,7 @@ import Cardano.Ledger.DRep (DRep (..))
 import Cardano.Ledger.Mary (MaryValue)
 import Cardano.Ledger.Mary.Value (MultiAsset)
 import Cardano.Ledger.Plutus.Data (Data)
-import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..))
+import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..), SLanguage (..))
 import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..))
 import Cardano.Ledger.Plutus.TxInfo (
   transBoundedRational,
@@ -130,6 +131,22 @@ import qualified PlutusLedgerApi.V3.MintValue as PV3
 instance EraPlutusContext ConwayEra where
   type ContextError ConwayEra = ConwayContextError ConwayEra
 
+  data TxInfoResult ConwayEra
+    = ConwayTxInfoResult -- Fields must be kept lazy
+        (Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV1))
+        (Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV2))
+        (Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV3))
+
+  mkTxInfoResult lti =
+    ConwayTxInfoResult
+      (toPlutusTxInfo SPlutusV1 lti)
+      (toPlutusTxInfo SPlutusV2 lti)
+      (toPlutusTxInfo SPlutusV3 lti)
+
+  lookupTxInfoResult SPlutusV1 (ConwayTxInfoResult tirPlutusV1 _ _) = tirPlutusV1
+  lookupTxInfoResult SPlutusV2 (ConwayTxInfoResult _ tirPlutusV2 _) = tirPlutusV2
+  lookupTxInfoResult SPlutusV3 (ConwayTxInfoResult _ _ tirPlutusV3) = tirPlutusV3
+
   mkPlutusWithContext = \case
     ConwayPlutusV1 p -> toPlutusWithContext $ Left p
     ConwayPlutusV2 p -> toPlutusWithContext $ Left p