|
| 1 | +{-# LANGUAGE AllowAmbiguousTypes #-} |
| 2 | +{-# LANGUAGE LambdaCase #-} |
| 3 | +{-# LANGUAGE TypeApplications #-} |
| 4 | + |
| 5 | +module Main (main) |
| 6 | +where |
| 7 | + |
| 8 | +import Parsers (Format (..), WhichLL (..), parseDumpOptions) |
| 9 | + |
| 10 | +import PlutusCore qualified as PLC |
| 11 | +import PlutusCore.Builtin qualified as PLC |
| 12 | +import PlutusCore.Default.Builtins qualified as PLC |
| 13 | +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC |
| 14 | + |
| 15 | +import PlutusLedgerApi.Common (IsParamName, PlutusLedgerLanguage (..), showParamName) |
| 16 | +import PlutusLedgerApi.V1 qualified as V1 |
| 17 | +import PlutusLedgerApi.V2 qualified as V2 |
| 18 | +import PlutusLedgerApi.V3 qualified as V3 |
| 19 | + |
| 20 | +import Data.Aeson qualified as A (Object, ToJSON, Value (Array, Number)) |
| 21 | +import Data.Aeson.Encode.Pretty (encodePretty) |
| 22 | +import Data.Aeson.Key qualified as K (fromString) |
| 23 | +import Data.Aeson.KeyMap qualified as KM (KeyMap, singleton) |
| 24 | +import Data.ByteString.Lazy (putStr) |
| 25 | +import Data.Int (Int64) |
| 26 | +import Data.List.Extra (enumerate) |
| 27 | +import Data.Map qualified as Map (lookup) |
| 28 | +import Data.Text (Text) |
| 29 | +import Data.Vector qualified as V (fromList) |
| 30 | +import Options.Applicative (execParser) |
| 31 | +import Text.Printf (printf) |
| 32 | + |
| 33 | +{- | This executable prints out the cost model parameters according to the various |
| 34 | + `PlutusLedgerApi.V<n>.ParamName types`. These determine both the cost model |
| 35 | + parameters included in the protocol parameters (and hence which Plutus |
| 36 | + builtins are available to each Plutus ledger language version) and the order |
| 37 | + in which they occur. The protocol parameters and the ledger both treat the |
| 38 | + cost model parameters as ordered lists of integers and know nothing about |
| 39 | + the names of the parameters (see |
| 40 | + `cardano-ledger/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs` |
| 41 | + for how the ledger (and also cardano-api and cardano-cli) deals with cost |
| 42 | + models), and the `ParamName` types provide the link between the lists of |
| 43 | + parameters and the complex structure used to represent a cost model in |
| 44 | + Plutus Core. New cost models (possibly enabling new builtins) are |
| 45 | + propagated to the chain by protocol updates which update the cost model |
| 46 | + parameters, and this executable produces lists of cost model parameters in a |
| 47 | + form suitable for inclusion in the protocol parameters, and so can be helpful |
| 48 | + when we need to propose new parameters for use on the chain, and to check |
| 49 | + that the on-chain parameters are as expected. Note that this code deals |
| 50 | + only with the cost model parameters in the current state of the `plutus` |
| 51 | + repository, which may differ from those on the chain: specifically, the cost |
| 52 | + model parameters dealt with by this code will often be those which are |
| 53 | + expected to come into effect at the next hard fork and hence will be ahead |
| 54 | + of those currently in use for new script executions on the chain. The exact |
| 55 | + structure of the cost model used by a particular ledger language is |
| 56 | + determined by a _semantic variant_ which depends on both the ledger language |
| 57 | + and the protocol version (see the `mkEvaluationContext` functions in the |
| 58 | + various `EvaluationContext` files), and this code will need to be updated |
| 59 | + if, for example, a new Plutus Ledger language is added or the structure of |
| 60 | + the cost model used by an existing ledger language changes. |
| 61 | +-} |
| 62 | + |
| 63 | +-- Mapping of LL versions to semantic versions and parameter names for *the |
| 64 | +-- current state of the repository*. This MUST be updated if the mappings in |
| 65 | +-- the PlutusLedgerApi.V<n>.EvaluationContext modules are changed. |
| 66 | +infoFor :: PlutusLedgerLanguage -> (PLC.BuiltinSemanticsVariant PLC.DefaultFun, [Text]) |
| 67 | +infoFor = |
| 68 | + let paramNames :: forall a . IsParamName a => [Text] |
| 69 | + paramNames = fmap showParamName $ enumerate @a |
| 70 | + in \case |
| 71 | + PlutusV1 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V1.ParamName) |
| 72 | + PlutusV2 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V2.ParamName) |
| 73 | + PlutusV3 -> (PLC.DefaultFunSemanticsVariantC, paramNames @V3.ParamName) |
| 74 | + |
| 75 | +-- Return the current cost model parameters for a given LL version in the form |
| 76 | +-- of a list of (name, value) pairs ordered by name according to the relevant |
| 77 | +-- `ParamName` type. |
| 78 | +getParamsFor :: PlutusLedgerLanguage -> [(Text, Int64)] |
| 79 | +getParamsFor ll = |
| 80 | + let (semvar, paramNames) = infoFor ll |
| 81 | + params = |
| 82 | + case PLC.defaultCostModelParamsForVariant semvar of |
| 83 | + Nothing -> error $ "Can't find default cost model parameters for " |
| 84 | + ++ show semvar |
| 85 | + Just p -> p |
| 86 | + lookupParam name = |
| 87 | + case Map.lookup name params of |
| 88 | + Nothing -> error $ "No entry for " ++ show name |
| 89 | + ++ " in cost model for semantic variant " |
| 90 | + ++ show semvar |
| 91 | + Just n -> (name, n) |
| 92 | + in fmap lookupParam paramNames |
| 93 | + |
| 94 | +-- A couple of convenience functions for dealing with JSON. |
| 95 | +mkObject :: String -> v -> KM.KeyMap v |
| 96 | +mkObject k v = KM.singleton (K.fromString k) v |
| 97 | + |
| 98 | +putJSON :: A.ToJSON a => a -> IO () |
| 99 | +putJSON = Data.ByteString.Lazy.putStr . encodePretty |
| 100 | + |
| 101 | +-- Return the cost model parameters for a given LL in the form of a JSON object |
| 102 | +-- containing the LL version and an array of parameter values. This is the same |
| 103 | +-- format that cardano-cli uses to render the protocol parameters. Cost model |
| 104 | +-- parameter names are not included in the protocol parameters: they used to be, |
| 105 | +-- but not any more. |
| 106 | +getParamsAsJSON :: PlutusLedgerLanguage -> A.Object |
| 107 | +getParamsAsJSON ll = |
| 108 | + let params = getParamsFor ll |
| 109 | + entries = A.Array $ V.fromList $ fmap (\(_,v) -> A.Number $ fromIntegral v) params |
| 110 | + in mkObject (show ll) entries |
| 111 | + |
| 112 | +printParameters :: Format -> PlutusLedgerLanguage -> IO () |
| 113 | +printParameters fmt ll = |
| 114 | + case fmt of |
| 115 | + Untagged -> do |
| 116 | + printf "%s:\n" $ show ll |
| 117 | + mapM_ (\(_,val) -> printf " %-d\n" val) $ getParamsFor ll |
| 118 | + printf "\n" |
| 119 | + Tagged -> do |
| 120 | + printf "%s:\n" $ show ll |
| 121 | + mapM_ (\(name,val) -> printf " %-12d -- %s\n" val name) $ getParamsFor ll |
| 122 | + printf "\n" |
| 123 | + JSON -> putJSON $ getParamsAsJSON ll |
| 124 | + |
| 125 | +-- Print the cost model parameters for all ledger languages. For JSON we have |
| 126 | +-- to create a single object containing parameters for all ledger language |
| 127 | +-- versions and print that; for the other formats we just print them all out in |
| 128 | +-- sequence. |
| 129 | +printAll :: Format -> IO () |
| 130 | +printAll fmt = |
| 131 | + case fmt of |
| 132 | + JSON -> putJSON $ mkObject "costModels" $ mconcat (fmap getParamsAsJSON enumerate) |
| 133 | + _ -> mapM_ (printParameters fmt) enumerate |
| 134 | + |
| 135 | +main :: IO () |
| 136 | +main = do |
| 137 | + (lls, fmt) <- execParser parseDumpOptions |
| 138 | + case lls of |
| 139 | + One ll -> printParameters fmt ll |
| 140 | + All -> printAll fmt |
0 commit comments