From e59ade14367261a68b156e4ec71e7f65de627957 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 28 Mar 2022 17:46:29 +0200 Subject: [PATCH] [Builtins] [Costing] Make costing more sharing-friendly (#4505) `validation` benchmarks got faster by ~3.2%. --- .../.plan.nix/plutus-core.nix | 2 + .../.plan.nix/plutus-core.nix | 2 + .../.plan.nix/plutus-core.nix | 2 + plutus-core/plutus-core.cabal | 2 + .../Evaluation/Machine/BuiltinCostModel.hs | 371 +--------------- .../Evaluation/Machine/CostingFun/Core.hs | 405 ++++++++++++++++++ .../Evaluation/Machine/CostingFun/JSON.hs | 95 ++++ 7 files changed, 514 insertions(+), 365 deletions(-) create mode 100644 plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs create mode 100644 plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-core.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-core.nix index 046de060f1d..0cf968f2475 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-core.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-core.nix @@ -196,6 +196,8 @@ "PlutusCore/Evaluation/Machine/BuiltinCostModel" "PlutusCore/Evaluation/Machine/Ck" "PlutusCore/Evaluation/Machine/CostModelInterface" + "PlutusCore/Evaluation/Machine/CostingFun/Core" + "PlutusCore/Evaluation/Machine/CostingFun/JSON" "PlutusCore/Evaluation/Machine/ExBudget" "PlutusCore/Evaluation/Machine/ExMemory" "PlutusCore/Evaluation/Machine/Exception" diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-core.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-core.nix index 046de060f1d..0cf968f2475 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-core.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-core.nix @@ -196,6 +196,8 @@ "PlutusCore/Evaluation/Machine/BuiltinCostModel" "PlutusCore/Evaluation/Machine/Ck" "PlutusCore/Evaluation/Machine/CostModelInterface" + "PlutusCore/Evaluation/Machine/CostingFun/Core" + "PlutusCore/Evaluation/Machine/CostingFun/JSON" "PlutusCore/Evaluation/Machine/ExBudget" "PlutusCore/Evaluation/Machine/ExMemory" "PlutusCore/Evaluation/Machine/Exception" diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-core.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-core.nix index 046de060f1d..0cf968f2475 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-core.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-core.nix @@ -196,6 +196,8 @@ "PlutusCore/Evaluation/Machine/BuiltinCostModel" "PlutusCore/Evaluation/Machine/Ck" "PlutusCore/Evaluation/Machine/CostModelInterface" + "PlutusCore/Evaluation/Machine/CostingFun/Core" + "PlutusCore/Evaluation/Machine/CostingFun/JSON" "PlutusCore/Evaluation/Machine/ExBudget" "PlutusCore/Evaluation/Machine/ExMemory" "PlutusCore/Evaluation/Machine/Exception" diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 3e5baf549be..4adcd98c6ff 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -57,6 +57,8 @@ library PlutusCore.Evaluation.Machine.BuiltinCostModel PlutusCore.Evaluation.Machine.Ck PlutusCore.Evaluation.Machine.CostModelInterface + PlutusCore.Evaluation.Machine.CostingFun.Core + PlutusCore.Evaluation.Machine.CostingFun.JSON PlutusCore.Evaluation.Machine.ExBudget PlutusCore.Evaluation.Machine.ExMemory PlutusCore.Evaluation.Machine.Exception diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs index bb07f7752bf..cf0c8daaa5a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -O0 #-} +{-# LANGUAGE StrictData #-} +-- So that we don't spend a lot of time optimizing loads of Core whose performance doesn't matter. +{-# OPTIONS_GHC -O0 #-} module PlutusCore.Evaluation.Machine.BuiltinCostModel ( BuiltinCostModel @@ -39,13 +41,13 @@ where import PlutusPrelude hiding (toList) +import PlutusCore.Evaluation.Machine.CostingFun.Core +import PlutusCore.Evaluation.Machine.CostingFun.JSON () import PlutusCore.Evaluation.Machine.ExBudget -import PlutusCore.Evaluation.Machine.ExMemory import Barbies import Data.Aeson import Data.Default.Class -import Data.Hashable import Data.Kind qualified as Kind import Deriving.Aeson import Language.Haskell.TH.Syntax hiding (Name, newName) @@ -175,364 +177,3 @@ deriving anyclass instance AllArgumentModels Default f => Default (BuiltinCostMo deriving stock instance AllArgumentModels Lift f => Lift (BuiltinCostModelBase f) deriving stock instance AllArgumentModels Show f => Show (BuiltinCostModelBase f) deriving stock instance AllArgumentModels Eq f => Eq (BuiltinCostModelBase f) - --- TODO there's probably a nice way to abstract over the number of arguments here. Feel free to implement it. - -data CostingFun model = CostingFun - { costingFunCpu :: model - , costingFunMemory :: model - } - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (Default, NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "costingFun", CamelToSnake)] (CostingFun model) - - ----------------- One-argument costing functions ---------------- - -data ModelOneArgument = - ModelOneArgumentConstantCost CostingInteger - | ModelOneArgumentLinearCost ModelLinearSize - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[ TagSingleConstructors - , SumTaggedObject "type" "arguments" - , ConstructorTagModifier (StripPrefix "ModelOneArgument", CamelToSnake)] - ModelOneArgument - -- Without TagSingleConstructors the format can change unexpectedly if - -- you add/remove constructors because you don't get the tags if there's - -- only one constructor but you do if there's more than one. -instance Default ModelOneArgument where - def = ModelOneArgumentConstantCost 0 - -runCostingFunOneArgument - :: CostingFun ModelOneArgument - -> ExMemory - -> ExBudget -runCostingFunOneArgument - (CostingFun cpu mem) mem1 = - ExBudget (ExCPU $ runOneArgumentModel cpu mem1) - (ExMemory $ runOneArgumentModel mem mem1) - -runOneArgumentModel - :: ModelOneArgument - -> ExMemory - -> CostingInteger -runOneArgumentModel (ModelOneArgumentConstantCost c) _ = c -runOneArgumentModel (ModelOneArgumentLinearCost (ModelLinearSize intercept slope)) (ExMemory s) = - s * slope + intercept - - ----------------- Two-argument costing functions ---------------- - --- | s * (x + y) + I -data ModelAddedSizes = ModelAddedSizes - { modelAddedSizesIntercept :: CostingInteger - , modelAddedSizesSlope :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelAddedSizes", CamelToSnake)] ModelAddedSizes - --- | s * (x - y) + I -data ModelSubtractedSizes = ModelSubtractedSizes - { modelSubtractedSizesIntercept :: CostingInteger - , modelSubtractedSizesSlope :: CostingInteger - , modelSubtractedSizesMinimum :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelSubtractedSizes", CamelToSnake)] ModelSubtractedSizes - -data ModelLinearSize = ModelLinearSize - { modelLinearSizeIntercept :: CostingInteger - , modelLinearSizeSlope :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelLinearSize", CamelToSnake)] ModelLinearSize - --- | s * (x * y) + I -data ModelMultipliedSizes = ModelMultipliedSizes - { modelMultipliedSizesIntercept :: CostingInteger - , modelMultipliedSizesSlope :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelMultipliedSizes", CamelToSnake)] ModelMultipliedSizes - --- | s * min(x, y) + I -data ModelMinSize = ModelMinSize - { modelMinSizeIntercept :: CostingInteger - , modelMinSizeSlope :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelMinSize", CamelToSnake)] ModelMinSize - --- | s * max(x, y) + I -data ModelMaxSize = ModelMaxSize - { modelMaxSizeIntercept :: CostingInteger - , modelMaxSizeSlope :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelMaxSize", CamelToSnake)] ModelMaxSize - --- | if p then s*x else c; p depends on usage -data ModelConstantOrLinear = ModelConstantOrLinear - { modelConstantOrLinearConstant :: CostingInteger - , modelConstantOrLinearIntercept :: CostingInteger - , modelConstantOrLinearSlope :: CostingInteger - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelConstantOrLinear", CamelToSnake)] ModelConstantOrLinear - --- | if p then f(x,y) else c; p depends on usage -data ModelConstantOrTwoArguments = ModelConstantOrTwoArguments - { modelConstantOrTwoArgumentsConstant :: CostingInteger - , modelConstantOrTwoArgumentsModel :: ModelTwoArguments - } deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[FieldLabelModifier (StripPrefix "modelConstantOrTwoArguments", CamelToSnake)] ModelConstantOrTwoArguments - - -data ModelTwoArguments = - ModelTwoArgumentsConstantCost CostingInteger - | ModelTwoArgumentsLinearInX ModelLinearSize - | ModelTwoArgumentsLinearInY ModelLinearSize - | ModelTwoArgumentsAddedSizes ModelAddedSizes - | ModelTwoArgumentsSubtractedSizes ModelSubtractedSizes - | ModelTwoArgumentsMultipliedSizes ModelMultipliedSizes - | ModelTwoArgumentsMinSize ModelMinSize - | ModelTwoArgumentsMaxSize ModelMaxSize - | ModelTwoArgumentsLinearOnDiagonal ModelConstantOrLinear - | ModelTwoArgumentsConstAboveDiagonal ModelConstantOrTwoArguments - | ModelTwoArgumentsConstBelowDiagonal ModelConstantOrTwoArguments - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[ TagSingleConstructors - , SumTaggedObject "type" "arguments" - , ConstructorTagModifier (StripPrefix "ModelTwoArguments", CamelToSnake)] - ModelTwoArguments - -instance Default ModelTwoArguments where - def = ModelTwoArgumentsConstantCost 0 - -runCostingFunTwoArguments - :: CostingFun ModelTwoArguments - -> ExMemory - -> ExMemory - -> ExBudget -runCostingFunTwoArguments (CostingFun cpu mem) mem1 mem2 = - ExBudget (ExCPU $ runTwoArgumentModel cpu mem1 mem2) - (ExMemory $ runTwoArgumentModel mem mem1 mem2) - -runTwoArgumentModel - :: ModelTwoArguments - -> ExMemory - -> ExMemory - -> CostingInteger -runTwoArgumentModel - (ModelTwoArgumentsConstantCost c) _ _ = c -runTwoArgumentModel - (ModelTwoArgumentsAddedSizes (ModelAddedSizes intercept slope)) (ExMemory size1) (ExMemory size2) = - (size1 + size2) * slope + intercept -- TODO is this even correct? If not, adjust the other implementations too. -runTwoArgumentModel - (ModelTwoArgumentsSubtractedSizes (ModelSubtractedSizes intercept slope minSize)) (ExMemory size1) (ExMemory size2) = - (max minSize (size1 - size2)) * slope + intercept -runTwoArgumentModel - (ModelTwoArgumentsMultipliedSizes (ModelMultipliedSizes intercept slope)) (ExMemory size1) (ExMemory size2) = - (size1 * size2) * slope + intercept -runTwoArgumentModel - (ModelTwoArgumentsMinSize (ModelMinSize intercept slope)) (ExMemory size1) (ExMemory size2) = - (min size1 size2) * slope + intercept -runTwoArgumentModel - (ModelTwoArgumentsMaxSize (ModelMaxSize intercept slope)) (ExMemory size1) (ExMemory size2) = - (max size1 size2) * slope + intercept -runTwoArgumentModel - (ModelTwoArgumentsLinearInX (ModelLinearSize intercept slope)) (ExMemory size1) (ExMemory _) = - size1 * slope + intercept -runTwoArgumentModel - (ModelTwoArgumentsLinearInY (ModelLinearSize intercept slope)) (ExMemory _) (ExMemory size2) = - size2 * slope + intercept -runTwoArgumentModel -- Off the diagonal, return the constant. On the diagonal, run the one-variable linear model. - (ModelTwoArgumentsLinearOnDiagonal (ModelConstantOrLinear c intercept slope)) (ExMemory xSize) (ExMemory ySize) = - if xSize == ySize - then xSize * slope + intercept - else c -runTwoArgumentModel -- Below the diagonal, return the constant. Above the diagonal, run the other model. - (ModelTwoArgumentsConstBelowDiagonal (ModelConstantOrTwoArguments c m)) xMem yMem = - if xMem > yMem - then c - else runTwoArgumentModel m xMem yMem -runTwoArgumentModel -- Above the diagonal, return the constant. Below the diagonal, run the other model. - (ModelTwoArgumentsConstAboveDiagonal (ModelConstantOrTwoArguments c m)) xMem yMem = - if xMem < yMem - then c - else runTwoArgumentModel m xMem yMem - - ----------------- Three-argument costing functions ---------------- - -data ModelThreeArguments = - ModelThreeArgumentsConstantCost CostingInteger - | ModelThreeArgumentsAddedSizes ModelAddedSizes - | ModelThreeArgumentsLinearInX ModelLinearSize - | ModelThreeArgumentsLinearInY ModelLinearSize - | ModelThreeArgumentsLinearInZ ModelLinearSize - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[ TagSingleConstructors - , SumTaggedObject "type" "arguments" - , ConstructorTagModifier (StripPrefix "ModelThreeArguments", CamelToSnake)] - ModelThreeArguments - -instance Default ModelThreeArguments where - def = ModelThreeArgumentsConstantCost 0 - -runThreeArgumentModel - :: ModelThreeArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> CostingInteger -runThreeArgumentModel (ModelThreeArgumentsConstantCost c) _ _ _ = c -runThreeArgumentModel (ModelThreeArgumentsAddedSizes (ModelAddedSizes intercept slope)) (ExMemory size1) (ExMemory size2) (ExMemory size3) = - (size1 + size2 + size3) * slope + intercept -runThreeArgumentModel (ModelThreeArgumentsLinearInX (ModelLinearSize intercept slope)) (ExMemory size1) _ _ = - size1 * slope + intercept -runThreeArgumentModel (ModelThreeArgumentsLinearInY (ModelLinearSize intercept slope)) _ (ExMemory size2) _ = - size2 * slope + intercept -runThreeArgumentModel (ModelThreeArgumentsLinearInZ (ModelLinearSize intercept slope)) _ _ (ExMemory size3) = - size3 * slope + intercept - -runCostingFunThreeArguments - :: CostingFun ModelThreeArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> ExBudget -runCostingFunThreeArguments (CostingFun cpu mem) mem1 mem2 mem3 = - ExBudget (ExCPU $ runThreeArgumentModel cpu mem1 mem2 mem3) - (ExMemory $ runThreeArgumentModel mem mem1 mem2 mem3) - - ----------------- Four-argument costing functions ---------------- - -data ModelFourArguments = - ModelFourArgumentsConstantCost CostingInteger - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[ TagSingleConstructors - , SumTaggedObject "type" "arguments" - , ConstructorTagModifier (StripPrefix "ModelFourArguments", CamelToSnake)] - ModelFourArguments - -instance Default ModelFourArguments where - def = ModelFourArgumentsConstantCost 0 - -runFourArgumentModel - :: ModelFourArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> CostingInteger -runFourArgumentModel (ModelFourArgumentsConstantCost c) _ _ _ _ = c - -runCostingFunFourArguments - :: CostingFun ModelFourArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExBudget -runCostingFunFourArguments (CostingFun cpu mem) mem1 mem2 mem3 mem4 = - ExBudget (ExCPU $ runFourArgumentModel cpu mem1 mem2 mem3 mem4) - (ExMemory $ runFourArgumentModel mem mem1 mem2 mem3 mem4) - - ----------------- Five-argument costing functions ---------------- - -data ModelFiveArguments = - ModelFiveArgumentsConstantCost CostingInteger - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[ TagSingleConstructors - , SumTaggedObject "type" "arguments" - , ConstructorTagModifier (StripPrefix "ModelFiveArguments", CamelToSnake)] - ModelFiveArguments - -instance Default ModelFiveArguments where - def = ModelFiveArgumentsConstantCost 0 - -runFiveArgumentModel - :: ModelFiveArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> CostingInteger -runFiveArgumentModel (ModelFiveArgumentsConstantCost c) _ _ _ _ _ = c - -runCostingFunFiveArguments - :: CostingFun ModelFiveArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExBudget -runCostingFunFiveArguments (CostingFun cpu mem) mem1 mem2 mem3 mem4 mem5 = - ExBudget (ExCPU $ runFiveArgumentModel cpu mem1 mem2 mem3 mem4 mem5) - (ExMemory $ runFiveArgumentModel mem mem1 mem2 mem3 mem4 mem5) - - ----------------- Six-argument costing functions ---------------- - -data ModelSixArguments = - ModelSixArgumentsConstantCost CostingInteger - deriving stock (Show, Eq, Generic, Lift) - deriving anyclass (NFData) - deriving (FromJSON, ToJSON) via CustomJSON - '[ TagSingleConstructors - , SumTaggedObject "type" "arguments" - , ConstructorTagModifier (StripPrefix "ModelSixArguments", CamelToSnake)] - ModelSixArguments - -instance Default ModelSixArguments where - def = ModelSixArgumentsConstantCost 0 - -runSixArgumentModel - :: ModelSixArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> CostingInteger -runSixArgumentModel (ModelSixArgumentsConstantCost c) _ _ _ _ _ _ = c - -runCostingFunSixArguments - :: CostingFun ModelSixArguments - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExMemory - -> ExBudget -runCostingFunSixArguments (CostingFun cpu mem) mem1 mem2 mem3 mem4 mem5 mem6 = - ExBudget (ExCPU $ runSixArgumentModel cpu mem1 mem2 mem3 mem4 mem5 mem6) - (ExMemory $ runSixArgumentModel mem mem1 mem2 mem3 mem4 mem5 mem6) - diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs new file mode 100644 index 00000000000..4fc3d8693da --- /dev/null +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/Core.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} + +{-# LANGUAGE StrictData #-} +module PlutusCore.Evaluation.Machine.CostingFun.Core + ( CostingFun(..) + , ModelAddedSizes(..) + , ModelSubtractedSizes(..) + , ModelConstantOrLinear(..) + , ModelConstantOrTwoArguments(..) + , ModelLinearSize(..) + , ModelMultipliedSizes(..) + , ModelMinSize(..) + , ModelMaxSize(..) + , ModelOneArgument(..) + , ModelTwoArguments(..) + , ModelThreeArguments(..) + , ModelFourArguments(..) + , ModelFiveArguments(..) + , ModelSixArguments(..) + , runCostingFunOneArgument + , runCostingFunTwoArguments + , runCostingFunThreeArguments + , runCostingFunFourArguments + , runCostingFunFiveArguments + , runCostingFunSixArguments + , Hashable + ) +where + +import PlutusCore.Evaluation.Machine.ExBudget +import PlutusCore.Evaluation.Machine.ExMemory + +import Control.DeepSeq +import Data.Default.Class +import Data.Hashable +import Deriving.Aeson +import GHC.Exts +import Language.Haskell.TH.Syntax hiding (Name, newName) + +data CostingFun model = CostingFun + { costingFunCpu :: model + , costingFunMemory :: model + } + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (Default, NFData) + +---------------- One-argument costing functions ---------------- + +data ModelOneArgument = + ModelOneArgumentConstantCost CostingInteger + | ModelOneArgumentLinearCost ModelLinearSize + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) +instance Default ModelOneArgument where + def = ModelOneArgumentConstantCost 0 + +{- Note [Optimizations of runCostingFun*] +We optimize all @runCostingFun*@ functions in the same way: + +1. the two @run*Model@ functions are called right after matching on the first argument, so that + they are partially computed and cached, which results in them being called only once per builtin +2. we use a strict case-expression for matching, which GHC can't move inside the resulting lambda + (unlike a strict let-expression for example) +3. the whole definition is marked with @INLINE@, because it gets worker-wrapper transformed and we + don't want to keep the worker separate from the wrapper as it just results in unnecessary + wrapping-unwrapping + +In order for @run*Model@ functions to be able to partially compute we need to define them +accordingly, i.e. by matching on the first argument and returning a lambda. We wrap one of the +clauses with a call to 'lazy', so that GHC does not "optimize" the function by moving matching to +the inside of the resulting lambda (which would defeat the whole purpose of caching the function). +It's enough to put 'lazy' in only one of the clauses for all of them to be compiled the right way. +We consistently choose the @*ConstantCost@ clause, because it doesn't need to be optimized anyway +and so a call to 'lazy' doesn't hurt there. + +Since we want @run*Model@ functions to partially compute, we mark them as @NOINLINE@ to prevent GHC +from inlining them and breaking the sharing friendliness. Without the @NOINLINE@ Core doesn't seem +to be worse, however it was verified that no @NOINLINE@ causes a slowdown in both the @validation@ +and @nofib@ benchmarks. + +Note that looking at the generated Core isn't really enough. We might have enemies down the pipeline, +for example @-fstg-lift-lams@ looks suspicious: + +> Enables the late lambda lifting optimisation on the STG intermediate language. This selectively +> lifts local functions to top-level by converting free variables into function parameters. + +This wasn't investigated. + +These optimizations gave us a ~3.2% speedup at the time this Note was written. +-} + +runCostingFunOneArgument + :: CostingFun ModelOneArgument + -> ExMemory + -> ExBudget +runCostingFunOneArgument (CostingFun cpu mem) = + case (runOneArgumentModel cpu, runOneArgumentModel mem) of + (!runCpu, !runMem) -> \mem1 -> + ExBudget (ExCPU $ runCpu mem1) + (ExMemory $ runMem mem1) +{-# INLINE runCostingFunOneArgument #-} + +runOneArgumentModel + :: ModelOneArgument + -> ExMemory + -> CostingInteger +runOneArgumentModel (ModelOneArgumentConstantCost c) = lazy $ \_ -> c +runOneArgumentModel (ModelOneArgumentLinearCost (ModelLinearSize intercept slope)) = \(ExMemory s) -> + s * slope + intercept +{-# NOINLINE runOneArgumentModel #-} + +---------------- Two-argument costing functions ---------------- + +-- | s * (x + y) + I +data ModelAddedSizes = ModelAddedSizes + { modelAddedSizesIntercept :: CostingInteger + , modelAddedSizesSlope :: CostingInteger + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +-- | s * (x - y) + I +data ModelSubtractedSizes = ModelSubtractedSizes + { modelSubtractedSizesIntercept :: CostingInteger + , modelSubtractedSizesSlope :: CostingInteger + , modelSubtractedSizesMinimum :: CostingInteger + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +data ModelLinearSize = ModelLinearSize + { modelLinearSizeIntercept :: CostingInteger + , modelLinearSizeSlope :: CostingInteger + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +-- | s * (x * y) + I +data ModelMultipliedSizes = ModelMultipliedSizes + { modelMultipliedSizesIntercept :: CostingInteger + , modelMultipliedSizesSlope :: CostingInteger + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +-- | s * min(x, y) + I +data ModelMinSize = ModelMinSize + { modelMinSizeIntercept :: CostingInteger + , modelMinSizeSlope :: CostingInteger + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +-- | s * max(x, y) + I +data ModelMaxSize = ModelMaxSize + { modelMaxSizeIntercept :: CostingInteger + , modelMaxSizeSlope :: CostingInteger + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +-- | if p then s*x else c; p depends on usage +data ModelConstantOrLinear = ModelConstantOrLinear + { modelConstantOrLinearConstant :: CostingInteger + , modelConstantOrLinearIntercept :: CostingInteger + , modelConstantOrLinearSlope :: CostingInteger + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +-- | if p then f(x,y) else c; p depends on usage +data ModelConstantOrTwoArguments = ModelConstantOrTwoArguments + { modelConstantOrTwoArgumentsConstant :: CostingInteger + , modelConstantOrTwoArgumentsModel :: ModelTwoArguments + } deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + + +data ModelTwoArguments = + ModelTwoArgumentsConstantCost CostingInteger + | ModelTwoArgumentsLinearInX ModelLinearSize + | ModelTwoArgumentsLinearInY ModelLinearSize + | ModelTwoArgumentsAddedSizes ModelAddedSizes + | ModelTwoArgumentsSubtractedSizes ModelSubtractedSizes + | ModelTwoArgumentsMultipliedSizes ModelMultipliedSizes + | ModelTwoArgumentsMinSize ModelMinSize + | ModelTwoArgumentsMaxSize ModelMaxSize + | ModelTwoArgumentsLinearOnDiagonal ModelConstantOrLinear + | ModelTwoArgumentsConstAboveDiagonal ModelConstantOrTwoArguments + | ModelTwoArgumentsConstBelowDiagonal ModelConstantOrTwoArguments + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +instance Default ModelTwoArguments where + def = ModelTwoArgumentsConstantCost 0 + +runCostingFunTwoArguments + :: CostingFun ModelTwoArguments + -> ExMemory + -> ExMemory + -> ExBudget +runCostingFunTwoArguments (CostingFun cpu mem) = + case (runTwoArgumentModel cpu, runTwoArgumentModel mem) of + (!runCpu, !runMem) -> \mem1 mem2 -> + ExBudget (ExCPU $ runCpu mem1 mem2) + (ExMemory $ runMem mem1 mem2) +{-# INLINE runCostingFunTwoArguments #-} + +runTwoArgumentModel + :: ModelTwoArguments + -> ExMemory + -> ExMemory + -> CostingInteger +runTwoArgumentModel + (ModelTwoArgumentsConstantCost c) = lazy $ \_ _ -> c +runTwoArgumentModel + (ModelTwoArgumentsAddedSizes (ModelAddedSizes intercept slope)) = \(ExMemory size1) (ExMemory size2) -> + (size1 + size2) * slope + intercept -- TODO is this even correct? If not, adjust the other implementations too. +runTwoArgumentModel + (ModelTwoArgumentsSubtractedSizes (ModelSubtractedSizes intercept slope minSize)) = \(ExMemory size1) (ExMemory size2) -> + (max minSize (size1 - size2)) * slope + intercept +runTwoArgumentModel + (ModelTwoArgumentsMultipliedSizes (ModelMultipliedSizes intercept slope)) = \(ExMemory size1) (ExMemory size2) -> + (size1 * size2) * slope + intercept +runTwoArgumentModel + (ModelTwoArgumentsMinSize (ModelMinSize intercept slope)) = \(ExMemory size1) (ExMemory size2) -> + (min size1 size2) * slope + intercept +runTwoArgumentModel + (ModelTwoArgumentsMaxSize (ModelMaxSize intercept slope)) = \(ExMemory size1) (ExMemory size2) -> + (max size1 size2) * slope + intercept +runTwoArgumentModel + (ModelTwoArgumentsLinearInX (ModelLinearSize intercept slope)) = \(ExMemory size1) (ExMemory _) -> + size1 * slope + intercept +runTwoArgumentModel + (ModelTwoArgumentsLinearInY (ModelLinearSize intercept slope)) = \(ExMemory _) (ExMemory size2) -> + size2 * slope + intercept +runTwoArgumentModel -- Off the diagonal, return the constant. On the diagonal, run the one-variable linear model. + (ModelTwoArgumentsLinearOnDiagonal (ModelConstantOrLinear c intercept slope)) = \(ExMemory xSize) (ExMemory ySize) -> + if xSize == ySize + then xSize * slope + intercept + else c +runTwoArgumentModel -- Below the diagonal, return the constant. Above the diagonal, run the other model. + (ModelTwoArgumentsConstBelowDiagonal (ModelConstantOrTwoArguments c m)) = + case runTwoArgumentModel m of + !run -> \xMem yMem -> + if xMem > yMem + then c + else run xMem yMem +runTwoArgumentModel -- Above the diagonal, return the constant. Below the diagonal, run the other model. + (ModelTwoArgumentsConstAboveDiagonal (ModelConstantOrTwoArguments c m)) = + case runTwoArgumentModel m of + !run -> \xMem yMem -> + if xMem < yMem + then c + else run xMem yMem +{-# NOINLINE runTwoArgumentModel #-} + + +---------------- Three-argument costing functions ---------------- + +data ModelThreeArguments = + ModelThreeArgumentsConstantCost CostingInteger + | ModelThreeArgumentsAddedSizes ModelAddedSizes + | ModelThreeArgumentsLinearInX ModelLinearSize + | ModelThreeArgumentsLinearInY ModelLinearSize + | ModelThreeArgumentsLinearInZ ModelLinearSize + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +instance Default ModelThreeArguments where + def = ModelThreeArgumentsConstantCost 0 + +runThreeArgumentModel + :: ModelThreeArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> CostingInteger +runThreeArgumentModel (ModelThreeArgumentsConstantCost c) = lazy $ \_ _ _ -> c +runThreeArgumentModel (ModelThreeArgumentsAddedSizes (ModelAddedSizes intercept slope)) = \(ExMemory size1) (ExMemory size2) (ExMemory size3) -> + (size1 + size2 + size3) * slope + intercept +runThreeArgumentModel (ModelThreeArgumentsLinearInX (ModelLinearSize intercept slope)) = \(ExMemory size1) _ _ -> + size1 * slope + intercept +runThreeArgumentModel (ModelThreeArgumentsLinearInY (ModelLinearSize intercept slope)) = \_ (ExMemory size2) _ -> + size2 * slope + intercept +runThreeArgumentModel (ModelThreeArgumentsLinearInZ (ModelLinearSize intercept slope)) = \_ _ (ExMemory size3) -> + size3 * slope + intercept +{-# NOINLINE runThreeArgumentModel #-} + +runCostingFunThreeArguments + :: CostingFun ModelThreeArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> ExBudget +runCostingFunThreeArguments (CostingFun cpu mem) = + case (runThreeArgumentModel cpu, runThreeArgumentModel mem) of + (!runCpu, !runMem) -> \mem1 mem2 mem3 -> + ExBudget (ExCPU $ runCpu mem1 mem2 mem3) + (ExMemory $ runMem mem1 mem2 mem3) +{-# INLINE runCostingFunThreeArguments #-} + + +---------------- Four-argument costing functions ---------------- + +data ModelFourArguments = + ModelFourArgumentsConstantCost CostingInteger + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +instance Default ModelFourArguments where + def = ModelFourArgumentsConstantCost 0 + +runFourArgumentModel + :: ModelFourArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> CostingInteger +runFourArgumentModel (ModelFourArgumentsConstantCost c) = lazy $ \_ _ _ _ -> c +{-# NOINLINE runFourArgumentModel #-} + +runCostingFunFourArguments + :: CostingFun ModelFourArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExBudget +runCostingFunFourArguments (CostingFun cpu mem) = + case (runFourArgumentModel cpu, runFourArgumentModel mem) of + (!runCpu, !runMem) -> \mem1 mem2 mem3 mem4 -> + ExBudget (ExCPU $ runCpu mem1 mem2 mem3 mem4) + (ExMemory $ runMem mem1 mem2 mem3 mem4) +{-# INLINE runCostingFunFourArguments #-} + + +---------------- Five-argument costing functions ---------------- + +data ModelFiveArguments = + ModelFiveArgumentsConstantCost CostingInteger + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +instance Default ModelFiveArguments where + def = ModelFiveArgumentsConstantCost 0 + +runFiveArgumentModel + :: ModelFiveArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> CostingInteger +runFiveArgumentModel (ModelFiveArgumentsConstantCost c) = lazy $ \_ _ _ _ _ -> c +{-# NOINLINE runFiveArgumentModel #-} + +runCostingFunFiveArguments + :: CostingFun ModelFiveArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExBudget +runCostingFunFiveArguments (CostingFun cpu mem) = + case (runFiveArgumentModel cpu, runFiveArgumentModel mem) of + (!runCpu, !runMem) -> \mem1 mem2 mem3 mem4 mem5 -> + ExBudget (ExCPU $ runCpu mem1 mem2 mem3 mem4 mem5) + (ExMemory $ runMem mem1 mem2 mem3 mem4 mem5) +{-# INLINE runCostingFunFiveArguments #-} + +---------------- Six-argument costing functions ---------------- + +data ModelSixArguments = + ModelSixArgumentsConstantCost CostingInteger + deriving stock (Show, Eq, Generic, Lift) + deriving anyclass (NFData) + +instance Default ModelSixArguments where + def = ModelSixArgumentsConstantCost 0 + +runSixArgumentModel + :: ModelSixArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> CostingInteger +runSixArgumentModel (ModelSixArgumentsConstantCost c) = lazy $ \_ _ _ _ _ _ -> c +{-# NOINLINE runSixArgumentModel #-} + +runCostingFunSixArguments + :: CostingFun ModelSixArguments + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExMemory + -> ExBudget +runCostingFunSixArguments (CostingFun cpu mem) = + case (runSixArgumentModel cpu, runSixArgumentModel mem) of + (!runCpu, !runMem) -> \mem1 mem2 mem3 mem4 mem5 mem6 -> + ExBudget (ExCPU $ runCpu mem1 mem2 mem3 mem4 mem5 mem6) + (ExMemory $ runMem mem1 mem2 mem3 mem4 mem5 mem6) +{-# INLINE runCostingFunSixArguments #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs new file mode 100644 index 00000000000..ac3f78d7b1d --- /dev/null +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/CostingFun/JSON.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -O0 #-} + +-- | A separate module for JSON instances, so that we can stick @-O0@ on it and avoid spending +-- a lot of time optimizing loads of Core whose performance doesn't matter. +module PlutusCore.Evaluation.Machine.CostingFun.JSON () where + +import Data.Aeson +import Deriving.Aeson + +import PlutusCore.Evaluation.Machine.CostingFun.Core + +type ModelJSON prefix = CustomJSON '[FieldLabelModifier (StripPrefix prefix, CamelToSnake)] + +type ModelArgumentJSON prefix = + CustomJSON + -- Without TagSingleConstructors the format can change unexpectedly if + -- you add/remove constructors because you don't get the tags if there's + -- only one constructor but you do if there's more than one. + '[ TagSingleConstructors + , SumTaggedObject "type" "arguments" + , ConstructorTagModifier (StripPrefix prefix, CamelToSnake)] + +deriving via ModelJSON "costingFun" (CostingFun model) + instance FromJSON model => FromJSON (CostingFun model) +deriving via ModelJSON "costingFun" (CostingFun model) + instance ToJSON model => ToJSON (CostingFun model) + +deriving via ModelArgumentJSON "ModelOneArgument" ModelOneArgument + instance FromJSON ModelOneArgument +deriving via ModelArgumentJSON "ModelOneArgument" ModelOneArgument + instance ToJSON ModelOneArgument +deriving via ModelArgumentJSON "ModelTwoArguments" ModelTwoArguments + instance FromJSON ModelTwoArguments +deriving via ModelArgumentJSON "ModelTwoArguments" ModelTwoArguments + instance ToJSON ModelTwoArguments +deriving via ModelArgumentJSON "ModelThreeArguments" ModelThreeArguments + instance FromJSON ModelThreeArguments +deriving via ModelArgumentJSON "ModelThreeArguments" ModelThreeArguments + instance ToJSON ModelThreeArguments +deriving via ModelArgumentJSON "ModelFourArguments" ModelFourArguments + instance FromJSON ModelFourArguments +deriving via ModelArgumentJSON "ModelFourArguments" ModelFourArguments + instance ToJSON ModelFourArguments +deriving via ModelArgumentJSON "ModelFiveArguments" ModelFiveArguments + instance FromJSON ModelFiveArguments +deriving via ModelArgumentJSON "ModelFiveArguments" ModelFiveArguments + instance ToJSON ModelFiveArguments +deriving via ModelArgumentJSON "ModelSixArguments" ModelSixArguments + instance FromJSON ModelSixArguments +deriving via ModelArgumentJSON "ModelSixArguments" ModelSixArguments + instance ToJSON ModelSixArguments + +deriving via ModelJSON "modelAddedSizes" ModelAddedSizes + instance FromJSON ModelAddedSizes +deriving via ModelJSON "modelAddedSizes" ModelAddedSizes + instance ToJSON ModelAddedSizes +deriving via ModelJSON "modelSubtractedSizes" ModelSubtractedSizes + instance FromJSON ModelSubtractedSizes +deriving via ModelJSON "modelSubtractedSizes" ModelSubtractedSizes + instance ToJSON ModelSubtractedSizes +deriving via ModelJSON "modelLinearSize" ModelLinearSize + instance FromJSON ModelLinearSize +deriving via ModelJSON "modelLinearSize" ModelLinearSize + instance ToJSON ModelLinearSize +deriving via ModelJSON "modelMultipliedSizes" ModelMultipliedSizes + instance FromJSON ModelMultipliedSizes +deriving via ModelJSON "modelMultipliedSizes" ModelMultipliedSizes + instance ToJSON ModelMultipliedSizes +deriving via ModelJSON "modelMinSize" ModelMinSize + instance FromJSON ModelMinSize +deriving via ModelJSON "modelMinSize" ModelMinSize + instance ToJSON ModelMinSize +deriving via ModelJSON "modelMaxSize" ModelMaxSize + instance FromJSON ModelMaxSize +deriving via ModelJSON "modelMaxSize" ModelMaxSize + instance ToJSON ModelMaxSize +deriving via ModelJSON "modelConstantOrLinear" ModelConstantOrLinear + instance FromJSON ModelConstantOrLinear +deriving via ModelJSON "modelConstantOrLinear" ModelConstantOrLinear + instance ToJSON ModelConstantOrLinear +deriving via ModelJSON "modelConstantOrTwoArguments" ModelConstantOrTwoArguments + instance FromJSON ModelConstantOrTwoArguments +deriving via ModelJSON "modelConstantOrTwoArguments" ModelConstantOrTwoArguments + instance ToJSON ModelConstantOrTwoArguments