Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[Costing] Provide support for multiple 'CostModel's #5851

Merged
Show file tree
Hide file tree
Changes from 36 commits
Commits
Show all changes
40 commits
Select commit Hold shift + click to select a range
49db6d5
[Builtins] Store 'BuiltinRuntime' lazily explicitly
effectfully Feb 27, 2024
e1d60b6
An additional variant
effectfully Feb 27, 2024
3c40023
Revert "[Builtins] Store 'BuiltinRuntime' lazily explicitly"
effectfully Feb 27, 2024
1705f9e
Fix validation benchmarks
effectfully Feb 28, 2024
32c08f0
Fix a bunch more stuff
effectfully Feb 29, 2024
3b5bd38
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Mar 15, 2024
3f96021
Cosmetics
effectfully Mar 15, 2024
430d7f9
Remove warnings
effectfully Mar 19, 2024
aef3def
Push 'MajorProtocolVersion' into 'MachineParameters'
effectfully Mar 19, 2024
21bb075
Make 'CostingPart' into a function
effectfully Mar 8, 2024
8fa97cc
Revert "Make 'CostingPart' into a function"
effectfully Mar 22, 2024
a9a71bd
Provide support for multiple 'CostModel's
effectfully Mar 22, 2024
3944b7f
Add 'SubDefaultFunSemanticsVariant'
effectfully Mar 26, 2024
0a1af53
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Mar 26, 2024
1843823
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Mar 27, 2024
3134e88
Fix the arbitrary evaluation nonsense in 'nofib'
effectfully Mar 27, 2024
86a176d
Revert "Add 'SubDefaultFunSemanticsVariant'"
effectfully Apr 1, 2024
53b49c2
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 1, 2024
d2b57a6
Revert "Fix the arbitrary evaluation nonsense in 'nofib'"
effectfully Apr 4, 2024
b6c9c3c
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 4, 2024
69fc298
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 9, 2024
12679c7
Put 'mkMachineParameters' inside the loop
effectfully Apr 9, 2024
6151af8
Make errors explicit
effectfully Apr 11, 2024
20e2677
Add a call to 'lazy' in 'toBuiltinsRuntime' out of paranoia
effectfully Apr 11, 2024
ecc9a85
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 11, 2024
e543b28
Fix 'haskell-conformance'
effectfully Apr 11, 2024
a336d02
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 13, 2024
12bbcc1
Comments
effectfully Apr 15, 2024
4d3ddb0
Use a list instead of a function
effectfully Apr 15, 2024
7a23b0e
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 15, 2024
846ae8e
Remove a bang
effectfully Apr 16, 2024
5bf9d5e
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 16, 2024
ae5718b
Add 'evaluationContextCacheIsComplete'
effectfully Apr 18, 2024
809675d
Refactoring and comments
effectfully Apr 18, 2024
28f46c7
More comments
effectfully Apr 18, 2024
9d8942d
Comments and fixes
effectfully Apr 18, 2024
039dce1
Tweaks
effectfully Apr 23, 2024
60bbf02
Merge branch 'master' of https://github.com/input-output-hk/plutus in…
effectfully Apr 25, 2024
1f1bf5e
Add 'Note [Mapping of protocol versions and ledger languages to seman…
effectfully Apr 25, 2024
e507dae
Add a changelog entry
effectfully Apr 25, 2024
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
3 changes: 1 addition & 2 deletions plutus-benchmark/bls12-381-costs/bench/Bench.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,6 @@ import PlutusBenchmark.Common (benchProgramCek, mkEvalCtx)
import PlutusLedgerApi.Common (EvaluationContext)
import PlutusTx.Prelude qualified as Tx

import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Data.ByteString qualified as BS (empty)

Expand Down Expand Up @@ -78,7 +77,7 @@ schnorrG2Verify ctx = bench "schnorrG2Verify" $ benchProgramCek ctx mkSchnorrG2V

main :: IO ()
main = do
evalCtx <- evaluate $ force mkEvalCtx
evalCtx <- evaluate mkEvalCtx
defaultMain [
bgroup "hashAndAddG1" $ fmap (benchHashAndAddG1 evalCtx) [0, 10..150]
, bgroup "hashAndAddG2" $ fmap (benchHashAndAddG2 evalCtx) [0, 10..150]
Expand Down
3 changes: 1 addition & 2 deletions plutus-benchmark/cek-calibration/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,6 @@ import PlutusTx.Plugin ()
import PlutusTx.Prelude as Tx
import UntypedPlutusCore as UPLC

import Control.DeepSeq (force)
import Control.Exception
import Control.Lens
import Control.Monad.Except
Expand Down Expand Up @@ -88,7 +87,7 @@ writePlc p =

main1 :: Haskell.IO ()
main1 = do
evalCtx <- evaluate $ force mkEvalCtx
evalCtx <- evaluate mkEvalCtx
defaultMainWith
(defaultConfig { C.csvFile = Just "cek-lists.csv" })
[mkListBMs evalCtx [0,10..1000]]
Expand Down
6 changes: 5 additions & 1 deletion plutus-benchmark/common/PlutusBenchmark/Common.hs
Original file line number Diff line number Diff line change
Expand Up @@ -162,7 +162,11 @@ mkEvalCtx =
Just p ->
let errOrCtx =
-- The validation benchmarks were all created from PlutusV1 scripts
LedgerApi.mkDynEvaluationContext DefaultFunSemanticsVariant1 p
LedgerApi.mkDynEvaluationContext
LedgerApi.PlutusV1
[DefaultFunSemanticsVariant1]
(const DefaultFunSemanticsVariant1)
p
in case errOrCtx of
Right ec -> ec
Left err -> error $ show err
Expand Down
3 changes: 1 addition & 2 deletions plutus-benchmark/lists/bench/Bench.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,6 @@ import PlutusBenchmark.Lists.Sum.Compiled qualified as Sum.Compiled
import PlutusBenchmark.Lists.Sum.HandWritten qualified as Sum.HandWritten
import PlutusLedgerApi.Common (EvaluationContext)

import Control.DeepSeq
import Control.Exception
import Data.Functor

Expand Down Expand Up @@ -55,5 +54,5 @@ main :: IO ()
main = do
-- Run each benchmark for at least 15 seconds. Change this with -L or --timeout.
config <- getConfig 15.0
evalCtx <- evaluate $ force mkEvalCtx
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I moved that force to the creation site, so that we can remove it from lots of call sites (which was risky to begin with, because we'd occasionally forget to add a force, thus distorting the benchmarking results).

evalCtx <- evaluate mkEvalCtx
defaultMainWith config $ benchmarks evalCtx
3 changes: 1 addition & 2 deletions plutus-benchmark/marlowe/bench/BenchCek.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,9 @@ module Main where
import PlutusBenchmark.Common (benchProgramCek, mkEvalCtx)
import Shared (runBenchmarks)

import Control.DeepSeq (force)
import Control.Exception (evaluate)

main :: IO ()
main = do
evalCtx <- evaluate $ force mkEvalCtx
evalCtx <- evaluate mkEvalCtx
runBenchmarks (benchProgramCek evalCtx)
3 changes: 1 addition & 2 deletions plutus-benchmark/nofib/bench/BenchCek.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,9 @@ module Main where

import Shared (benchTermCek, benchWith, mkEvalCtx)

import Control.DeepSeq (force)
import Control.Exception (evaluate)

main :: IO ()
main = do
evalCtx <- evaluate $ force mkEvalCtx
evalCtx <- evaluate mkEvalCtx
benchWith $ benchTermCek evalCtx
6 changes: 0 additions & 6 deletions plutus-benchmark/plutus-benchmark.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -149,7 +149,6 @@ benchmark nofib
build-depends:
, base >=4.9 && <5
, criterion >=1.5.9.0
, deepseq
, nofib-internal
, plutus-benchmark-common

Expand Down Expand Up @@ -225,7 +224,6 @@ benchmark lists
build-depends:
, base >=4.9 && <5
, criterion >=1.5.9.0
, deepseq
, lists-internal
, plutus-benchmark-common
, plutus-ledger-api
Expand Down Expand Up @@ -262,7 +260,6 @@ benchmark validation
, base >=4.9 && <5
, bytestring
, criterion >=1.5.9.0
, deepseq
, directory
, filepath
, flat ^>=0.6
Expand Down Expand Up @@ -323,7 +320,6 @@ benchmark cek-calibration
build-depends:
, base >=4.9 && <5
, criterion >=1.5.9.0
, deepseq
, lens
, mtl
, plutus-benchmark-common
Expand Down Expand Up @@ -425,7 +421,6 @@ benchmark bls12-381-benchmarks
, bls12-381lib-internal
, bytestring
, criterion >=1.5.9.0
, deepseq
, plutus-benchmark-common
, plutus-ledger-api ^>=1.25
, plutus-tx ^>=1.25
Expand Down Expand Up @@ -518,7 +513,6 @@ benchmark marlowe
build-depends:
, base >=4.9 && <5
, criterion
, deepseq
, marlowe-internal
, plutus-benchmark-common
, plutus-ledger-api ^>=1.25
Expand Down
3 changes: 1 addition & 2 deletions plutus-benchmark/validation/bench/BenchCek.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,6 @@
module Main where

import Common (benchTermCek, benchWith, mkEvalCtx, unsafeUnflat)
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import PlutusBenchmark.Common (toNamedDeBruijnTerm)
import UntypedPlutusCore as UPLC
Expand All @@ -17,7 +16,7 @@ import UntypedPlutusCore as UPLC
-}
main :: IO ()
main = do
evalCtx <- evaluate $ force mkEvalCtx
evalCtx <- evaluate mkEvalCtx
let mkCekBM file program =
benchTermCek evalCtx . toNamedDeBruijnTerm . UPLC._progTerm $ unsafeUnflat file program
benchWith mkCekBM
2 changes: 1 addition & 1 deletion plutus-benchmark/validation/bench/BenchFull.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ the whole time taken from script deserialization to script execution result.
-}
main :: IO ()
main = do
evalCtx <- evaluate $ force mkEvalCtx
evalCtx <- evaluate mkEvalCtx
let mkFullBM :: FilePath -> BS.ByteString -> Benchmarkable
mkFullBM file bsFlat =
let UPLC.Program () ver body = unsafeUnflat file bsFlat
Expand Down
6 changes: 3 additions & 3 deletions plutus-conformance/haskell/Spec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,9 +12,9 @@ import UntypedPlutusCore.Evaluation.Machine.Cek (CountingSt (..), counting, runC
evalUplcProg :: UplcEvaluator
evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) ->
do
params <- case mkMachineParametersFor def modelParams of
Left _ -> Nothing
Right p -> Just p
params <- case mkMachineParametersFor [def] modelParams of
Left _ -> Nothing
Right machParamsList -> lookup def machParamsList
effectfully marked this conversation as resolved.
Show resolved Hide resolved
-- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with free variables,
-- that is why we manually check first for any free vars
case UPLC.deBruijnTerm t of
Expand Down
5 changes: 4 additions & 1 deletion plutus-core/executables/src/PlutusCore/Executable/Parsers.hs
Original file line number Diff line number Diff line change
Expand Up @@ -141,6 +141,7 @@ exampleOpts = ExampleOptions <$> exampleMode
builtinSemanticsVariantReader :: String -> Maybe (BuiltinSemanticsVariant DefaultFun)
builtinSemanticsVariantReader =
\case
"0" -> Just DefaultFunSemanticsVariant0
"1" -> Just DefaultFunSemanticsVariant1
"2" -> Just DefaultFunSemanticsVariant2
_ -> Nothing
Expand All @@ -149,6 +150,7 @@ builtinSemanticsVariantReader =
showBuiltinSemanticsVariant :: BuiltinSemanticsVariant DefaultFun -> String
showBuiltinSemanticsVariant =
\case
DefaultFunSemanticsVariant0 -> "0"
DefaultFunSemanticsVariant1 -> "1"
DefaultFunSemanticsVariant2 -> "2"

Expand All @@ -160,7 +162,8 @@ builtinSemanticsVariant = option (maybeReader builtinSemanticsVariantReader)
<> value DefaultFunSemanticsVariant2
<> showDefaultWith showBuiltinSemanticsVariant
<> help
("Builtin semantics variant: 1 -> DefaultFunSemanticsVariant1, "
("Builtin semantics variant: 0 -> DefaultFunSemanticsVariant0, "
<> "1 -> DefaultFunSemanticsVariant1"
<> "2 -> DefaultFunSemanticsVariant2"
)
)
Expand Down
30 changes: 11 additions & 19 deletions plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,6 @@ import PlutusCore.Evaluation.Machine.ExBudgetStream
import PlutusCore.Evaluation.Machine.ExMemoryUsage
import PlutusCore.Name.Unique

import Control.DeepSeq
import Data.Array
import Data.Kind qualified as GHC
import Data.Proxy
Expand Down Expand Up @@ -399,22 +398,15 @@ toBuiltinsRuntime
-> cost
-> BuiltinsRuntime fun val
toBuiltinsRuntime semvar cost =
let runtime = BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar
-- This pragma is very important, removing it destroys the carefully set up optimizations of
-- of costing functions (see Note [Optimizations of runCostingFun*]). The reason for that is
-- that if @runtime@ doesn't have a pragma, then GHC sees that it's only referenced once and
-- inlines it below, together with this entire function (since we tell GHC to), at which
-- point everything's inlined and we're completely at GHC's mercy to optimize things
-- properly. Unfortunately, GHC doesn't want to cooperate and push 'toBuiltinRuntime' to
-- the inside of the inlined to 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's
-- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a
-- lambda binding the @cost@ variable, which renders all the optimizations useless. By
-- using a @NOINLINE@ pragma we tell GHC to create a separate thunk, which it can properly
-- optimize, because the other bazillion things don't get in the way.
{-# NOINLINE runtime #-}
in
-- Force each 'BuiltinRuntime' to WHNF, so that the thunk is allocated and forced at
-- initialization time rather than at runtime. Not that we'd lose much by not forcing all
-- 'BuiltinRuntime's here, but why pay even very little if there's an easy way not to pay.
force runtime
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We now have force in mkMachineParametersFor, so we don't need it here.

-- A call to 'lazy' is to make sure that the returned 'BuiltinsRuntime' is properly cached in a
-- 'let'-binding. This makes it easier for GHC to optimize the internals of builtins, because
-- without a 'let'-binding GHC would sometimes refuse to cooperate and push 'toBuiltinRuntime'
-- to the inside of the inlined 'toBuiltinMeaning' call, creating lots of 'BuiltinMeaning's
-- instead of 'BuiltinRuntime's with the former hiding the costing optimizations behind a lambda
-- binding the @cost@ variable, which makes the optimizations useless.
-- By using 'lazy' we tell GHC to create a separate thunk, which it can properly optimize,
-- because the other bazillion things don't get in the way. We used to use an explicit
-- 'let'-binding marked with @NOINLINE@, but that turned out to be unreliable, because GHC
-- feels free to turn it into a join point instead of a proper thunk.
lazy . BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning semvar
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

As I said during the GHC Core presentation, lazy is way more reliable here than let + NOINLINE.

{-# INLINE toBuiltinsRuntime #-}
31 changes: 18 additions & 13 deletions plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,7 @@ import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Flat hiding (from, to)
import Flat.Decoder (Get, dBEBits8)
import Flat.Encoder as Flat (Encoding, NumBits, eBits)
import NoThunks.Class (NoThunks)
import Prettyprinter (viaShow)

-- See Note [Pattern matching on built-in types].
Expand Down Expand Up @@ -1075,10 +1076,12 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
possibly different semantics. Note that DefaultFunSemanticsVariant1,
DefaultFunSemanticsVariant1 etc. do not correspond directly to PlutusV1,
PlutusV2 etc. in plutus-ledger-api: see Note [Builtin semantics variants]. -}
data BuiltinSemanticsVariant DefaultFun =
DefaultFunSemanticsVariant1
| DefaultFunSemanticsVariant2
deriving stock (Enum, Bounded, Show)
data BuiltinSemanticsVariant DefaultFun
= DefaultFunSemanticsVariant0
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I vote that we change these to DefaultSemanticsVariantA/B/C or something similar. It's quite confusing having all these variants and versions in the code, so it might help if they're not all identified by numbers that might lead people to believe that the same number means the same thing in different contexts. That would mean changing the specification too though, so if we do it let's do it later in its own PR.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm fine either way. I'm hopeful we'll be able to get rid of the semantics variants entirely and simply rely on the language and protocol versions directly (maybe in the "condensed" form).

| DefaultFunSemanticsVariant1
| DefaultFunSemanticsVariant2
deriving stock (Eq, Enum, Bounded, Show, Generic)
deriving anyclass (NFData, NoThunks)

-- Integers
toBuiltinMeaning
Expand Down Expand Up @@ -1176,6 +1179,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
appendByteStringDenotation
(runCostingFunTwoArguments . paramAppendByteString)

-- See Note [Builtin semantics variants]
toBuiltinMeaning semvar ConsByteString =
-- The costing function is the same for all variants of this builtin,
-- but since the denotation of the builtin accepts constants of
Expand All @@ -1185,26 +1189,26 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
:: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream
costingFun = runCostingFunTwoArguments . paramConsByteString
{-# INLINE costingFun #-}
-- See Note [Builtin semantics variants]
in case semvar of
DefaultFunSemanticsVariant1 ->
consByteStringMeaning_V1 =
let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString
consByteStringDenotation n xs = BS.cons (fromIntegral n) xs
{-# INLINE consByteStringDenotation #-}
in makeBuiltinMeaning
consByteStringDenotation
costingFun
-- For builtin semantics variants other (i.e. larger) than
-- DefaultFunSemanticsVariant1, the first input must be in range
-- [0..255]. See Note [How to add a built-in function: simple
-- cases]
DefaultFunSemanticsVariant2 ->
-- For builtin semantics variants larger than 'DefaultFunSemanticsVariant1', the first
-- input must be in range @[0..255]@.
consByteStringMeaning_V2 =
let consByteStringDenotation :: Word8 -> BS.ByteString -> BS.ByteString
consByteStringDenotation = BS.cons
{-# INLINE consByteStringDenotation #-}
in makeBuiltinMeaning
consByteStringDenotation
costingFun
in case semvar of
DefaultFunSemanticsVariant0 -> consByteStringMeaning_V1
DefaultFunSemanticsVariant1 -> consByteStringMeaning_V1
DefaultFunSemanticsVariant2 -> consByteStringMeaning_V2

toBuiltinMeaning _semvar SliceByteString =
let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString
Expand Down Expand Up @@ -1287,7 +1291,8 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
:: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool
verifyEd25519SignatureDenotation =
case semvar of
DefaultFunSemanticsVariant1 -> verifyEd25519Signature_V1
DefaultFunSemanticsVariant0 -> verifyEd25519Signature_V1
DefaultFunSemanticsVariant1 -> verifyEd25519Signature_V2
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This mapping is potentially easy to get wrong. Is there any test for this?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We're just replacing one implementation with another for maintenance reasons, so doing this matching here is only for the purpose of being paranoid about not breaking anything in the past in case of some unknown unknown. There's nothing additional to test therefore beyond what we already test, which is how we use ed25519_Variant0Prop to test all variants of this builtin.

Note that consByteString is untestable in the same way, but for a different reason: Variant0 and Variant1 versions of that builtin are completely identical (unlike with verifyEd25519Signature, whose variants behave identically but come from different libraries, i.e. are nominally different), so again there's nothing to test.

So for both the builtins we only make sure that whatever their variant is, it behaves as expected, we cannot test that Variant0 behaves differently from Variant1, because it doesn't.

DefaultFunSemanticsVariant2 -> verifyEd25519Signature_V2
{-# INLINE verifyEd25519SignatureDenotation #-}
in makeBuiltinMeaning
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@ module PlutusCore.Evaluation.Machine.ExBudgetingDefaults
( defaultBuiltinsRuntimeForSemanticsVariant
, defaultBuiltinsRuntime
, defaultCekCostModel
, toCekCostModel
, defaultCekMachineCosts
, defaultCekParameters
, defaultCostModelParams
Expand Down Expand Up @@ -85,6 +86,9 @@ defaultCekMachineCosts =
defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel
defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel

toCekCostModel :: BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel
toCekCostModel _ = defaultCekCostModel
Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Here's where we get the additional extensibility.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Should it therefore have some comment explaining that?


-- | The default cost model data. This is exposed to the ledger, so let's not
-- confuse anybody by mentioning the CEK machine
defaultCostModelParams :: Maybe CostModelParams
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -3,13 +3,16 @@
-- we need to be able to visually inspect, hence we dedicate a separate file to it.
module PlutusCore.Evaluation.Machine.MachineParameters.Default where

import PlutusPrelude

import PlutusCore.Builtin
import PlutusCore.Default
import PlutusCore.Evaluation.Machine.CostModelInterface
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
import PlutusCore.Evaluation.Machine.MachineParameters
import UntypedPlutusCore.Evaluation.Machine.Cek

import Control.DeepSeq (force)
import Control.Monad.Except
import GHC.Exts (inline)

Expand Down Expand Up @@ -41,8 +44,9 @@ as we did have cases where sticking 'inline' on something that already had @INLI
inlining).
-}

-- | Produce a 'DefaultMachineParameters' given the version of the default set of built-in functions
-- and a 'CostModelParams', which gets applied on top of 'defaultCekCostModel'.
-- | Produce a 'DefaultMachineParameters' for each of the given semantics variants.
-- The 'CostModelParams' argument is used to update the costing parameters returned by
-- 'toCekCostModel' for each of the semantics variants.
--
-- Whenever you need to evaluate UPLC in a performance-sensitive manner (e.g. in the production,
-- for benchmarking, for cost calibration etc), you MUST use this definition for creating a
Expand All @@ -53,16 +57,21 @@ inlining).
-- Core; you change how it's exported (implicitly as a part of a whole-module export or explicitly
-- as a single definition) -- you get the idea.
--
-- This function is expensive, so its result needs to be cached if it's going to be used multiple
-- times.
-- This function is very expensive, so its result needs to be cached if it's going to be used
-- multiple times.
mkMachineParametersFor
:: MonadError CostModelApplyError m
=> BuiltinSemanticsVariant DefaultFun
=> [BuiltinSemanticsVariant DefaultFun]
-> CostModelParams
-> m DefaultMachineParameters
mkMachineParametersFor semvar newCMP =
inline mkMachineParameters semvar <$>
applyCostModelParams defaultCekCostModel newCMP
-> m [(BuiltinSemanticsVariant DefaultFun, DefaultMachineParameters)]
mkMachineParametersFor semVars newCMP = do
res <- for semVars $ \semVar ->
-- See Note [Inlining meanings of builtins].
(,) semVar . inline mkMachineParameters semVar <$>
applyCostModelParams (toCekCostModel semVar) newCMP
-- Force all thunks to pay the cost of creating machine parameters upfront. Doing it here saves
-- us from doing that in every single benchmark runner.
pure $! force res
-- Not marking this function with @INLINE@, since at this point everything we wanted to be inlined
-- is inlined and there's zero reason to duplicate thousands and thousands of lines of Core down
-- the line.