diff --git a/plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs b/plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs new file mode 100644 index 00000000000..20ed264c615 --- /dev/null +++ b/plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +module Main (main) +where + +import Parsers (Format (..), WhichLL (..), parseDumpOptions) + +import PlutusCore qualified as PLC +import PlutusCore.Builtin qualified as PLC +import PlutusCore.Default.Builtins qualified as PLC +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC + +import PlutusLedgerApi.Common (IsParamName, PlutusLedgerLanguage (..), showParamName) +import PlutusLedgerApi.V1 qualified as V1 +import PlutusLedgerApi.V2 qualified as V2 +import PlutusLedgerApi.V3 qualified as V3 + +import Data.Aeson qualified as A (Object, ToJSON, Value (Array, Number)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Aeson.Key qualified as K (fromString) +import Data.Aeson.KeyMap qualified as KM (KeyMap, singleton) +import Data.ByteString.Lazy (putStr) +import Data.Int (Int64) +import Data.List.Extra (enumerate) +import Data.Map qualified as Map (lookup) +import Data.Text (Text) +import Data.Vector qualified as V (fromList) +import Options.Applicative (execParser) +import Text.Printf (printf) + +{- | This executable prints out the cost model parameters according to the various + `PlutusLedgerApi.V.ParamName types`. These determine both the cost model + parameters included in the protocol parameters (and hence which Plutus + builtins are available to each Plutus ledger language version) and the order + in which they occur. The protocol parameters and the ledger both treat the + cost model parameters as ordered lists of integers and know nothing about + the names of the parameters (see + `cardano-ledger/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs` + for how the ledger (and also cardano-api and cardano-cli) deals with cost + models), and the `ParamName` types provide the link between the lists of + parameters and the complex structure used to represent a cost model in + Plutus Core. New cost models (possibly enabling new builtins) are + propagated to the chain by protocol updates which update the cost model + parameters, and this executable produces lists of cost model parameters in a + form suitable for inclusion in the protocol parameters, and so can be helpful + when we need to propose new parameters for use on the chain, and to check + that the on-chain parameters are as expected. Note that this code deals + only with the cost model parameters in the current state of the `plutus` + repository, which may differ from those on the chain: specifically, the cost + model parameters dealt with by this code will often be those which are + expected to come into effect at the next hard fork and hence will be ahead + of those currently in use for new script executions on the chain. The exact + structure of the cost model used by a particular ledger language is + determined by a _semantic variant_ which depends on both the ledger language + and the protocol version (see the `mkEvaluationContext` functions in the + various `EvaluationContext` files), and this code will need to be updated + if, for example, a new Plutus Ledger language is added or the structure of + the cost model used by an existing ledger language changes. +-} + +-- Mapping of LL versions to semantic versions and parameter names for *the +-- current state of the repository*. This MUST be updated if the mappings in +-- the PlutusLedgerApi.V.EvaluationContext modules are changed. +infoFor :: PlutusLedgerLanguage -> (PLC.BuiltinSemanticsVariant PLC.DefaultFun, [Text]) +infoFor = + let paramNames :: forall a . IsParamName a => [Text] + paramNames = fmap showParamName $ enumerate @a + in \case + PlutusV1 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V1.ParamName) + PlutusV2 -> (PLC.DefaultFunSemanticsVariantB, paramNames @V2.ParamName) + PlutusV3 -> (PLC.DefaultFunSemanticsVariantC, paramNames @V3.ParamName) + +-- Return the current cost model parameters for a given LL version in the form +-- of a list of (name, value) pairs ordered by name according to the relevant +-- `ParamName` type. +getParamsFor :: PlutusLedgerLanguage -> [(Text, Int64)] +getParamsFor ll = + let (semvar, paramNames) = infoFor ll + params = + case PLC.defaultCostModelParamsForVariant semvar of + Nothing -> error $ "Can't find default cost model parameters for " + ++ show semvar + Just p -> p + lookupParam name = + case Map.lookup name params of + Nothing -> error $ "No entry for " ++ show name + ++ " in cost model for semantic variant " + ++ show semvar + Just n -> (name, n) + in fmap lookupParam paramNames + +-- A couple of convenience functions for dealing with JSON. +mkObject :: String -> v -> KM.KeyMap v +mkObject k v = KM.singleton (K.fromString k) v + +putJSON :: A.ToJSON a => a -> IO () +putJSON = Data.ByteString.Lazy.putStr . encodePretty + +-- Return the cost model parameters for a given LL in the form of a JSON object +-- containing the LL version and an array of parameter values. This is the same +-- format that cardano-cli uses to render the protocol parameters. Cost model +-- parameter names are not included in the protocol parameters: they used to be, +-- but not any more. +getParamsAsJSON :: PlutusLedgerLanguage -> A.Object +getParamsAsJSON ll = + let params = getParamsFor ll + entries = A.Array $ V.fromList $ fmap (\(_,v) -> A.Number $ fromIntegral v) params + in mkObject (show ll) entries + +printParameters :: Format -> PlutusLedgerLanguage -> IO () +printParameters fmt ll = + case fmt of + Untagged -> do + printf "%s:\n" $ show ll + mapM_ (\(_,val) -> printf " %-d\n" val) $ getParamsFor ll + printf "\n" + Tagged -> do + printf "%s:\n" $ show ll + mapM_ (\(name,val) -> printf " %-12d -- %s\n" val name) $ getParamsFor ll + printf "\n" + JSON -> putJSON $ getParamsAsJSON ll + +-- Print the cost model parameters for all ledger languages. For JSON we have +-- to create a single object containing parameters for all ledger language +-- versions and print that; for the other formats we just print them all out in +-- sequence. +printAll :: Format -> IO () +printAll fmt = + case fmt of + JSON -> putJSON $ mkObject "costModels" $ mconcat (fmap getParamsAsJSON enumerate) + _ -> mapM_ (printParameters fmt) enumerate + +main :: IO () +main = do + (lls, fmt) <- execParser parseDumpOptions + case lls of + One ll -> printParameters fmt ll + All -> printAll fmt diff --git a/plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs b/plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs new file mode 100644 index 00000000000..97e5b76c0d3 --- /dev/null +++ b/plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE LambdaCase #-} + +module Parsers (Format(..), WhichLL(..), parseDumpOptions) +where + +import Options.Applicative +import PlutusLedgerApi.Common.Versions (PlutusLedgerLanguage (..)) + +data WhichLL = + One PlutusLedgerLanguage -- Print parameters for a single LL. + | All -- Print parameters for all LLs. + deriving stock (Show) + +parseVersion :: ReadM WhichLL +parseVersion = eitherReader $ \case + "1" -> Right $ One PlutusV1 + "2" -> Right $ One PlutusV2 + "3" -> Right $ One PlutusV3 + s -> Left $ "Unknown ledger language version: " ++ s + +whichll :: Parser WhichLL +whichll = + option parseVersion + (short 'V' <> + metavar "N" <> + help "Print parameters for PlutusV only" + ) + <|> flag All All + -- This makes `All` the default: if the previous parser fails then we + -- arrive here and it returns `All` whether or not the option is + -- present on the command line. + (short 'a' <> + long "all" <> + help "Print parameters for all Plutus ledger language versions (default)" + ) + +data Format = Untagged | Tagged | JSON + deriving stock (Show) + +format :: Parser Format +format = + flag' Untagged (short 'u' <> long "untagged" <> help "Print parameter values only") + <|> flag' Tagged (short 't' <> long "tagged" <> help "Print parameter values and names") + <|> flag JSON JSON (short 'j' <> long "json" <> help "Print parameters in JSON format (default)") + +dumpOptions :: Parser (WhichLL, Format) +dumpOptions = (,) <$> whichll <*> format + +parseDumpOptions :: ParserInfo (WhichLL, Format) +parseDumpOptions = + info (dumpOptions <**> helper) + (fullDesc <> + progDesc ("Print the current (and possibly undeployed) cost model parameters " + ++ " in the plutus repository in the order used in the protocol parameters.\n" + ++ "The purpose of this tool is to help with the deployment and verification " + ++ "of updated cost model parameters: it MUST be kept up to date with the " + ++ "`mkEvaluationContext` functions in plututus-ledger-api.")) diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 28573f38b4b..65a7d7eeb38 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -259,6 +259,7 @@ executable test-onchain-evaluation main-is: Main.hs other-modules: LoadScriptEvents hs-source-dirs: exe/test-onchain-evaluation exe/common + default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , async @@ -273,13 +274,12 @@ executable test-onchain-evaluation , tasty , tasty-hunit - default-language: Haskell2010 - executable analyse-script-events import: lang main-is: Main.hs other-modules: LoadScriptEvents hs-source-dirs: exe/analyse-script-events exe/common + default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , base >=4.9 && <5 @@ -294,4 +294,22 @@ executable analyse-script-events , primitive , serialise +executable dump-cost-model-parameters + import: lang + main-is: Main.hs + other-modules: Parsers + hs-source-dirs: exe/dump-cost-model-parameters default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson + , aeson-pretty + , base >=4.9 && <5 + , bytestring + , containers + , extra + , optparse-applicative + , plutus-core ^>=1.48 + , plutus-ledger-api ^>=1.48 + , text + , vector