Skip to content

Commit c9e2fda

Browse files
lehinslehins
authored
Merge pull request #4854 from IntersectMBO/lehins/TxInfo-memoization
`TxInfo` memoization
2 parents 585ad35 + 6caaebf commit c9e2fda

File tree

6 files changed

+104
-37
lines changed

6 files changed

+104
-37
lines changed

‎eras/alonzo/impl/CHANGELOG.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,9 @@
22

33
## 1.13.0.0
44

5+
* Add `TxInfoResult` data family, `mkTxInfoResult` and `lookupTxInfoResult` to `EraPlutusContext`
6+
* Add `lookupTxInfoResultImpossible` helper
7+
* Add `TxInfoResult era` parameter to `toPlutusWithContext` and `mkPlutusWithContext`
58
* Made the fields of predicate failures and environments lazy
69
* Add `MemPack` instance for `Addr28Extra`, `DataHash32`, `AlonzoTxOut` and `PlutusScript AlonzoEra`
710
* Deprecate `hashAlonzoTxAuxData`

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

Lines changed: 36 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -7,12 +7,16 @@
77
{-# LANGUAGE TypeApplications #-}
88
{-# LANGUAGE TypeFamilyDependencies #-}
99
{-# LANGUAGE UndecidableSuperClasses #-}
10+
-- Recursive definition constraints of `EraPlutusContext` and `EraPlutusTxInfo` lead to a wrongful
11+
-- redundant constraint warning in the definition of `lookupTxInfoResult`
12+
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
1013

1114
module Cardano.Ledger.Alonzo.Plutus.Context (
1215
LedgerTxInfo (..),
1316
EraPlutusTxInfo (..),
1417
EraPlutusContext (..),
1518
toPlutusWithContext,
19+
lookupTxInfoResultImpossible,
1620

1721
-- * Language dependent translation
1822
PlutusTxInfo,
@@ -45,15 +49,17 @@ import Cardano.Ledger.Plutus (
4549
PlutusRunnable,
4650
PlutusScriptContext,
4751
PlutusWithContext (..),
52+
SLanguage (..),
53+
isLanguage,
4854
)
4955
import Cardano.Ledger.UTxO (UTxO (..))
5056
import Cardano.Slotting.EpochInfo (EpochInfo)
5157
import Cardano.Slotting.Time (SystemStart)
5258
import Control.DeepSeq (NFData)
5359
import Data.Aeson (ToJSON)
5460
import Data.Kind (Type)
55-
import Data.Proxy (Proxy (..))
5661
import Data.Text (Text)
62+
import GHC.Stack
5763
import NoThunks.Class (NoThunks)
5864
import qualified PlutusLedgerApi.V1 as PV1
5965
import qualified PlutusLedgerApi.V2 as PV2
@@ -109,11 +115,28 @@ class
109115
where
110116
type ContextError era = (r :: Type) | r -> era
111117

118+
-- | This data type family is used to memoize the results of `toPlutusTxInfo`, so the outcome can
119+
-- be shared between execution of different scripts with the same language version.
120+
data TxInfoResult era :: Type
121+
122+
-- | Construct `PlutusTxInfo` for all supported languages in this era.
123+
mkTxInfoResult :: LedgerTxInfo era -> TxInfoResult era
124+
125+
-- | `TxInfo` for the same language can be shared between executions of every script of the same
126+
-- version in a single transaction.
127+
--
128+
-- /Note/ - The `EraPlutusTxInfo` is here only to enforce this function is not called with an
129+
-- unsupported plutus language version.
130+
lookupTxInfoResult ::
131+
EraPlutusTxInfo l era =>
132+
SLanguage l -> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
133+
112134
mkPlutusWithContext ::
113135
PlutusScript era ->
114136
ScriptHash ->
115137
PlutusPurpose AsIxItem era ->
116138
LedgerTxInfo era ->
139+
TxInfoResult era ->
117140
(Data era, ExUnits) ->
118141
CostModel ->
119142
Either (ContextError era) PlutusWithContext
@@ -125,16 +148,17 @@ toPlutusWithContext ::
125148
ScriptHash ->
126149
PlutusPurpose AsIxItem era ->
127150
LedgerTxInfo era ->
151+
TxInfoResult era ->
128152
(Data era, ExUnits) ->
129153
CostModel ->
130154
Either (ContextError era) PlutusWithContext
131-
toPlutusWithContext script scriptHash plutusPurpose lti (redeemerData, exUnits) costModel = do
132-
let proxy = Proxy @l
155+
toPlutusWithContext script scriptHash plutusPurpose lti txInfoResult (redeemerData, exUnits) costModel = do
156+
let slang = isLanguage @l
133157
maybeSpendingDatum =
134158
getSpendingDatum (ltiUTxO lti) (ltiTx lti) (hoistPlutusPurpose toAsItem plutusPurpose)
135-
txInfo <- toPlutusTxInfo proxy lti
159+
txInfo <- lookupTxInfoResult slang txInfoResult
136160
plutusArgs <-
137-
toPlutusArgs proxy (ltiProtVer lti) txInfo plutusPurpose maybeSpendingDatum redeemerData
161+
toPlutusArgs slang (ltiProtVer lti) txInfo plutusPurpose maybeSpendingDatum redeemerData
138162
pure $
139163
PlutusWithContext
140164
{ pwcProtocolVersion = pvMajor (ltiProtVer lti)
@@ -145,6 +169,13 @@ toPlutusWithContext script scriptHash plutusPurpose lti (redeemerData, exUnits)
145169
, pwcCostModel = costModel
146170
}
147171

172+
-- | Helper function to use when implementing `lookupTxInfoResult` for plutus languages that are not
173+
-- supported by the era.
174+
lookupTxInfoResultImpossible ::
175+
(HasCallStack, EraPlutusTxInfo l era) => SLanguage l -> Either (ContextError era) (PlutusTxInfo l)
176+
lookupTxInfoResultImpossible slang =
177+
error $ "Impossible: Attempt to lookup TxInfoResult for an unsupported language: " <> show slang
178+
148179
-- =============================================
149180
-- Type families that specify Plutus types that are different from one version to another
150181

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

Lines changed: 21 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -17,11 +17,13 @@
1717

1818
module Cardano.Ledger.Alonzo.Plutus.Evaluate (
1919
evalPlutusScripts,
20-
evalPlutusScriptsWithLogs,
2120
CollectError (..),
2221
collectPlutusScriptsWithContext,
2322

2423
-- * Execution units estimation
24+
25+
-- | Functions in this section are provided for testing and downstream users like cardano-api
26+
evalPlutusScriptsWithLogs,
2527
TransactionScriptFailure (..),
2628
evalTxExUnits,
2729
RedeemerReport,
@@ -35,7 +37,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext (..)
3537
import Cardano.Ledger.Alonzo.Scripts (lookupPlutusScript, plutusScriptLanguage, toAsItem, toAsIx)
3638
import Cardano.Ledger.Alonzo.TxWits (lookupRedeemer, unRedeemers)
3739
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded (..))
38-
import Cardano.Ledger.BaseTypes (ProtVer (pvMajor), kindObject, natVersion, pvMajor)
40+
import Cardano.Ledger.BaseTypes (kindObject)
3941
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
4042
import Cardano.Ledger.Binary.Coders
4143
import Cardano.Ledger.Plutus.CostModels (costModelsValid)
@@ -53,15 +55,13 @@ import Cardano.Ledger.UTxO (EraUTxO (..), ScriptsProvided (..), UTxO (..))
5355
import Cardano.Slotting.EpochInfo (EpochInfo)
5456
import Cardano.Slotting.Time (SystemStart)
5557
import Control.DeepSeq (NFData)
56-
import Control.Monad (guard)
5758
import Data.Aeson (ToJSON (..), (.=), pattern String)
5859
import Data.Bifunctor (first)
5960
import Data.List (intercalate)
6061
import Data.Map.Strict (Map)
6162
import qualified Data.Map.Strict as Map
6263
import Data.MapExtras (fromElems)
6364
import Data.Maybe (mapMaybe)
64-
import qualified Data.Set as Set
6565
import Data.Text (Text)
6666
import qualified Debug.Trace as Debug
6767
import GHC.Generics
@@ -153,31 +153,28 @@ collectPlutusScriptsWithContext ::
153153
UTxO era ->
154154
Either [CollectError era] [PlutusWithContext]
155155
collectPlutusScriptsWithContext epochInfo systemStart pp tx utxo =
156-
-- TODO: remove this whole complicated check when we get into Conway. It is much simpler
157-
-- to fail on a CostModel lookup in the `apply` function (already implemented).
158-
let missingCostModels = Set.filter (`Map.notMember` costModels) usedLanguages
159-
in case guard (pvMajor protVer < natVersion @9) >> Set.lookupMin missingCostModels of
160-
Just l -> Left [NoCostModel l]
161-
Nothing ->
162-
merge
163-
apply
164-
(map getScriptWithRedeemer neededPlutusScripts)
165-
(Right [])
156+
merge
157+
apply
158+
(map getScriptWithRedeemer neededPlutusScripts)
159+
(Right [])
166160
where
167-
-- Check on a protocol version to preserve failure mode (a single NoCostModel failure
168-
-- for languages with missing cost models) until we are in Conway era. After we hard
169-
-- fork into Conway it will be safe to remove this check together with the
170-
-- `missingCostModels` lookup
171-
--
172-
-- We also need to pass major protocol version to the script for script evaluation
161+
-- We need to pass major protocol version to the script for script evaluation
173162
protVer = pp ^. ppProtocolVersionL
174163
costModels = costModelsValid $ pp ^. ppCostModelsL
164+
ledgerTxInfo =
165+
LedgerTxInfo
166+
{ ltiProtVer = protVer
167+
, ltiEpochInfo = epochInfo
168+
, ltiSystemStart = systemStart
169+
, ltiUTxO = utxo
170+
, ltiTx = tx
171+
}
172+
txInfoResult = mkTxInfoResult ledgerTxInfo
175173

176174
ScriptsProvided scriptsProvided = getScriptsProvided utxo tx
177175
AlonzoScriptsNeeded scriptsNeeded = getScriptsNeeded utxo (tx ^. bodyTxL)
178176
neededPlutusScripts =
179177
mapMaybe (\(sp, sh) -> (,) (sh, sp) <$> lookupPlutusScript sh scriptsProvided) scriptsNeeded
180-
usedLanguages = Set.fromList $ map (plutusScriptLanguage . snd) neededPlutusScripts
181178

182179
getScriptWithRedeemer ((plutusScriptHash, plutusPurpose), plutusScript) =
183180
let redeemerIndex = hoistPlutusPurpose toAsIx plutusPurpose
@@ -186,21 +183,14 @@ collectPlutusScriptsWithContext epochInfo systemStart pp tx utxo =
186183
Nothing -> Left (NoRedeemer (hoistPlutusPurpose toAsItem plutusPurpose))
187184
apply (plutusScript, plutusPurpose, redeemerData, exUnits, plutusScriptHash) = do
188185
let lang = plutusScriptLanguage plutusScript
189-
ledgerTxInfo =
190-
LedgerTxInfo
191-
{ ltiProtVer = protVer
192-
, ltiEpochInfo = epochInfo
193-
, ltiSystemStart = systemStart
194-
, ltiUTxO = utxo
195-
, ltiTx = tx
196-
}
197186
costModel <- maybe (Left (NoCostModel lang)) Right $ Map.lookup lang costModels
198187
first BadTranslation $
199188
mkPlutusWithContext
200189
plutusScript
201190
plutusScriptHash
202191
plutusPurpose
203192
ledgerTxInfo
193+
txInfoResult
204194
(redeemerData, exUnits)
205195
costModel
206196

@@ -378,6 +368,7 @@ evalTxExUnitsWithLogs pp tx utxo epochInfo systemStart = Map.mapWithKey findAndC
378368
, ltiUTxO = utxo
379369
, ltiTx = tx
380370
}
371+
txInfoResult = mkTxInfoResult ledgerTxInfo
381372
maxBudget = pp ^. ppMaxTxExUnitsL
382373
txBody = tx ^. bodyTxL
383374
wits = tx ^. witsTxL
@@ -412,6 +403,7 @@ evalTxExUnitsWithLogs pp tx utxo epochInfo systemStart = Map.mapWithKey findAndC
412403
plutusScriptHash
413404
plutusPurpose
414405
ledgerTxInfo
406+
txInfoResult
415407
(redeemerData, maxBudget)
416408
costModel
417409
case evaluatePlutusWithContext P.Verbose pwc of

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

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,12 @@ import Cardano.Ledger.Mary.Value (
6969
PolicyID (..),
7070
)
7171
import Cardano.Ledger.Plutus.Data (Data, getPlutusData)
72-
import Cardano.Ledger.Plutus.Language (Language (..), LegacyPlutusArgs (..), PlutusArgs (..))
72+
import Cardano.Ledger.Plutus.Language (
73+
Language (..),
74+
LegacyPlutusArgs (..),
75+
PlutusArgs (..),
76+
SLanguage (..),
77+
)
7378
import Cardano.Ledger.Plutus.TxInfo
7479
import Cardano.Ledger.PoolParams (PoolParams (..))
7580
import Cardano.Ledger.Rules.ValidationMode (Inject (..))
@@ -157,6 +162,13 @@ toLegacyPlutusArgs proxy pv mkScriptContext scriptPurpose maybeSpendingData rede
157162

158163
instance EraPlutusContext AlonzoEra where
159164
type ContextError AlonzoEra = AlonzoContextError AlonzoEra
165+
newtype TxInfoResult AlonzoEra
166+
= AlonzoTxInfoResult (Either (ContextError AlonzoEra) (PlutusTxInfo 'PlutusV1))
167+
168+
mkTxInfoResult = AlonzoTxInfoResult . toPlutusTxInfo SPlutusV1
169+
170+
lookupTxInfoResult SPlutusV1 (AlonzoTxInfoResult tirPlutusV1) = tirPlutusV1
171+
lookupTxInfoResult slang _ = lookupTxInfoResultImpossible slang
160172

161173
mkPlutusWithContext (AlonzoPlutusV1 p) = toPlutusWithContext (Left p)
162174

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

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,8 @@ import Cardano.Ledger.Alonzo.Plutus.Context (
3232
EraPlutusTxInfo (..),
3333
LedgerTxInfo (..),
3434
PlutusScriptPurpose,
35+
PlutusTxInfo,
36+
lookupTxInfoResultImpossible,
3537
toPlutusWithContext,
3638
)
3739
import Cardano.Ledger.Alonzo.Plutus.TxInfo (
@@ -65,7 +67,7 @@ import Cardano.Ledger.Binary.Coders (
6567
import Cardano.Ledger.Mary.Value (MaryValue)
6668
import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, getPlutusData)
6769
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
68-
import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..))
70+
import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..), SLanguage (..))
6971
import Cardano.Ledger.Plutus.TxInfo (
7072
TxOutSource (..),
7173
transAddr,
@@ -221,6 +223,16 @@ transTxRedeemers proxy pv tx =
221223

222224
instance EraPlutusContext BabbageEra where
223225
type ContextError BabbageEra = BabbageContextError BabbageEra
226+
data TxInfoResult BabbageEra
227+
= BabbageTxInfoResult -- Fields must be kept lazy
228+
(Either (ContextError BabbageEra) (PlutusTxInfo 'PlutusV1))
229+
(Either (ContextError BabbageEra) (PlutusTxInfo 'PlutusV2))
230+
231+
mkTxInfoResult lti = BabbageTxInfoResult (toPlutusTxInfo SPlutusV1 lti) (toPlutusTxInfo SPlutusV2 lti)
232+
233+
lookupTxInfoResult SPlutusV1 (BabbageTxInfoResult tirPlutusV1 _) = tirPlutusV1
234+
lookupTxInfoResult SPlutusV2 (BabbageTxInfoResult _ tirPlutusV2) = tirPlutusV2
235+
lookupTxInfoResult slang _ = lookupTxInfoResultImpossible slang
224236

225237
mkPlutusWithContext = \case
226238
BabbagePlutusV1 p -> toPlutusWithContext $ Left p

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

Lines changed: 18 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ import Cardano.Ledger.Alonzo.Plutus.Context (
3636
EraPlutusTxInfo (..),
3737
LedgerTxInfo (..),
3838
PlutusTxCert,
39+
PlutusTxInfo,
3940
toPlutusWithContext,
4041
)
4142
import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), TxOutSource (..))
@@ -92,7 +93,7 @@ import Cardano.Ledger.DRep (DRep (..))
9293
import Cardano.Ledger.Mary (MaryValue)
9394
import Cardano.Ledger.Mary.Value (MultiAsset)
9495
import Cardano.Ledger.Plutus.Data (Data)
95-
import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..))
96+
import Cardano.Ledger.Plutus.Language (Language (..), PlutusArgs (..), SLanguage (..))
9697
import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..))
9798
import Cardano.Ledger.Plutus.TxInfo (
9899
transBoundedRational,
@@ -130,6 +131,22 @@ import qualified PlutusLedgerApi.V3.MintValue as PV3
130131
instance EraPlutusContext ConwayEra where
131132
type ContextError ConwayEra = ConwayContextError ConwayEra
132133

134+
data TxInfoResult ConwayEra
135+
= ConwayTxInfoResult -- Fields must be kept lazy
136+
(Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV1))
137+
(Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV2))
138+
(Either (ContextError ConwayEra) (PlutusTxInfo 'PlutusV3))
139+
140+
mkTxInfoResult lti =
141+
ConwayTxInfoResult
142+
(toPlutusTxInfo SPlutusV1 lti)
143+
(toPlutusTxInfo SPlutusV2 lti)
144+
(toPlutusTxInfo SPlutusV3 lti)
145+
146+
lookupTxInfoResult SPlutusV1 (ConwayTxInfoResult tirPlutusV1 _ _) = tirPlutusV1
147+
lookupTxInfoResult SPlutusV2 (ConwayTxInfoResult _ tirPlutusV2 _) = tirPlutusV2
148+
lookupTxInfoResult SPlutusV3 (ConwayTxInfoResult _ _ tirPlutusV3) = tirPlutusV3
149+
133150
mkPlutusWithContext = \case
134151
ConwayPlutusV1 p -> toPlutusWithContext $ Left p
135152
ConwayPlutusV2 p -> toPlutusWithContext $ Left p

0 commit comments

Comments
 (0)