Skip to content

Commit

Permalink
[Costing] Provide support for multiple 'CostModel's (IntersectMBO#5851)
Browse files Browse the repository at this point in the history
  • Loading branch information
effectfully authored and v0d1ch committed Dec 6, 2024
1 parent 2c983f9 commit a282337
Show file tree
Hide file tree
Showing 31 changed files with 275 additions and 170 deletions.
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
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 ^>=1.26
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.26
, plutus-tx ^>=1.26
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.26
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
-- 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
-- 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
{-# 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
| 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
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,11 @@ defaultCekMachineCosts =
defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel
defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel

-- | Return the 'CostModel' corresponding to the given semantics variant. The dependency on the
-- semantics variant is what makes cost models configurable.
toCekCostModel :: BuiltinSemanticsVariant DefaultFun -> CostModel CekMachineCosts BuiltinCostModel
toCekCostModel _ = defaultCekCostModel

-- | 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.
Loading

0 comments on commit a282337

Please sign in to comment.