Value costing: insertCoin, unionValue, scaleValue

plutus-core/cost-model/budgeting-bench/Benchmarks/Values.hs

@@ -11,20 +11,20 @@ import Prelude
 
 import Common
 import Control.Monad (replicateM)
+import Control.Monad.State.Strict (State)
 import Criterion.Main (Benchmark)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
-import Data.Int (Int64)
 import Data.List (find, sort)
 import Data.Word (Word8)
 import GHC.Stack (HasCallStack)
-import PlutusCore (DefaultFun (LookupCoin, UnValueData, ValueContains, ValueData))
+import PlutusCore (DefaultFun (InsertCoin, LookupCoin, ScaleValue, UnValueData, UnionValue, ValueContains, ValueData))
 import PlutusCore.Builtin (BuiltinResult (BuiltinFailure, BuiltinSuccess, BuiltinSuccessWithLogs))
 import PlutusCore.Evaluation.Machine.ExMemoryUsage (ValueLogOuterSizeAddLogMaxInnerSize (..),
                                                     ValueTotalSize (..))
-import PlutusCore.Value (K, Value)
+import PlutusCore.Value (K, Quantity (..), Value)
 import PlutusCore.Value qualified as Value
-import System.Random.Stateful (StatefulGen, StdGen, runStateGen_, uniformRM)
+import System.Random.Stateful (StateGenM, StatefulGen, StdGen, runStateGen_, uniformRM)
 
 ----------------------------------------------------------------------------------------------------
 -- Benchmarks --------------------------------------------------------------------------------------
@@ -35,6 +35,9 @@ makeBenchmarks gen =
   , valueContainsBenchmark gen
   , valueDataBenchmark gen
   , unValueDataBenchmark gen
+  , insertCoinBenchmark gen
+  , unionValueBenchmark gen
+  , scaleValueBenchmark gen
   ]
 
 ----------------------------------------------------------------------------------------------------
@@ -46,10 +49,10 @@ lookupCoinBenchmark gen =
     (id, id, ValueLogOuterSizeAddLogMaxInnerSize) -- Wrap Value argument to report sum of log sizes
     LookupCoin -- the builtin fun
     [] -- no type arguments needed (monomorphic builtin)
-    (lookupCoinArgs gen) -- the argument combos to generate benchmarks for
+    (runBenchGen gen lookupCoinArgs) -- the argument combos to generate benchmarks for
 
-lookupCoinArgs :: StdGen -> [(ByteString, ByteString, Value)]
-lookupCoinArgs gen = runStateGen_ gen \(g :: g) -> do
+lookupCoinArgs :: (StatefulGen g m) => g -> m [(ByteString, ByteString, Value)]
+lookupCoinArgs gen = do
   {- Exhaustive power-of-2 combinations for BST worst-case benchmarking.
 
      Tests all combinations of sizes from powers and half-powers of 2.
@@ -80,7 +83,7 @@ lookupCoinArgs gen = runStateGen_ gen \(g :: g) -> do
 
   sequence
     -- Generate worst-case lookups for each size combination
-    [ withWorstCaseSearchKeys (generateConstrainedValueWithMaxPolicy numPolicies tokensPerPolicy g)
+    [ withWorstCaseSearchKeys (generateConstrainedValueWithMaxPolicy numPolicies tokensPerPolicy gen)
     | numPolicies <- sizes
     , tokensPerPolicy <- sizes
     ]
@@ -210,6 +213,61 @@ unValueDataBenchmark :: StdGen -> Benchmark
 unValueDataBenchmark gen =
   createOneTermBuiltinBench UnValueData [] (Value.valueData <$> generateTestValues gen)
 
+----------------------------------------------------------------------------------------------------
+-- InsertCoin --------------------------------------------------------------------------------------
+
+insertCoinBenchmark :: StdGen -> Benchmark
+insertCoinBenchmark gen =
+  createFourTermBuiltinBenchElementwiseWithWrappers
+    (id, id, id, ValueLogOuterSizeAddLogMaxInnerSize)
+    InsertCoin
+    []
+    (runBenchGen gen insertCoinArgs)
+
+insertCoinArgs :: (StatefulGen g m) => g -> m [(ByteString, ByteString, Integer, Value)]
+insertCoinArgs gen = do
+  lookupArgs <- lookupCoinArgs gen
+  let noOfBenchs = length lookupArgs
+  amounts <- genZeroOrMaxAmount gen noOfBenchs
+  pure $ reorderArgs <$> zip lookupArgs amounts
+  where
+    reorderArgs ((b1, b2, val), am) = (b1, b2, am, val)
+
+----------------------------------------------------------------------------------------------------
+-- UnionValue --------------------------------------------------------------------------------------
+
+unionValueBenchmark :: StdGen -> Benchmark
+unionValueBenchmark gen =
+  createTwoTermBuiltinBenchElementwiseWithWrappers
+    (ValueTotalSize, ValueTotalSize)
+    UnionValue
+    []
+    (runBenchGen gen unionValueArgs)
+
+unionValueArgs :: (StatefulGen g m) => g -> m [(Value, Value)]
+unionValueArgs gen = do
+  vals1 <- replicateM 100 (generateValue gen)
+  vals2 <- replicateM 100 (generateValue gen)
+  pure $ zip vals1 vals2
+
+----------------------------------------------------------------------------------------------------
+-- ScaleValue --------------------------------------------------------------------------------------
+
+scaleValueBenchmark :: StdGen -> Benchmark
+scaleValueBenchmark gen =
+  createTwoTermBuiltinBenchElementwiseWithWrappers
+    (id, ValueTotalSize)
+    ScaleValue
+    []
+    (runBenchGen gen scaleValueArgs)
+
+scaleValueArgs :: (StatefulGen g m) => g -> m [(Integer, Value)]
+scaleValueArgs gen = do
+  replicateM 100 $ do
+    (i1, i2) <- genBoundedProduct gen
+    val <- generateValueWithQuantity (mkQuantity $ sqrtMax - 1000) gen
+    pure (i1, val)
+
 ----------------------------------------------------------------------------------------------------
 -- Value Generators --------------------------------------------------------------------------------
 
@@ -228,6 +286,12 @@ generateValue g = do
   numEntries <- uniformRM (1, maxValueEntries) g
   generateValueMaxEntries numEntries g
 
+-- | Generate Value with random number of entries between 1 and maxValueEntries
+generateValueWithQuantity :: (StatefulGen g m) => Quantity -> g -> m Value
+generateValueWithQuantity qty g = do
+  numEntries <- uniformRM (1, maxValueEntries) g
+  generateValueMaxEntriesWithQuantity numEntries qty g
+
 -- | Maximum number of (policyId, tokenName, quantity) entries for Value generation.
 -- This represents the practical limit based on execution budget constraints.
 -- Scripts can programmatically generate large Values, so we benchmark based on
@@ -248,22 +312,37 @@ generateValueMaxEntries maxEntries g = do
 
   generateConstrainedValue numPolicies tokensPerPolicy g
 
+generateValueMaxEntriesWithQuantity :: (StatefulGen g m) => Int -> Quantity -> g -> m Value
+generateValueMaxEntriesWithQuantity maxEntries qty g = do
+  -- Uniform random distribution: cover full range from many policies (few tokens each)
+  -- to few policies (many tokens each)
+  numPolicies <- uniformRM (1, maxEntries) g
+  let tokensPerPolicy = if numPolicies > 0 then maxEntries `div` numPolicies else 0
+
+  generateConstrainedValueWithQuantity numPolicies tokensPerPolicy qty g
+
 -- | Generate constrained Value with information about max-size policy
 generateConstrainedValueWithMaxPolicy
   :: (StatefulGen g m)
   => Int -- Number of policies
   -> Int -- Number of tokens per policy
   -> g
   -> m (Value, K, K) -- Returns (value, maxPolicyId, deepestTokenInMaxPolicy)
-generateConstrainedValueWithMaxPolicy numPolicies tokensPerPolicy g = do
+generateConstrainedValueWithMaxPolicy numPolicies tokensPerPolicy g =
+  generateConstrainedValueWithMaxPolicyAndQuantity numPolicies tokensPerPolicy maxBound g
+
+-- | Generate constrained Value with information about max-size policy and quantity
+generateConstrainedValueWithMaxPolicyAndQuantity
+  :: (StatefulGen g m)
+  => Int -- Number of policies
+  -> Int -- Number of tokens per policy
+  -> Quantity -- Each token gets user defined quantity
+  -> g
+  -> m (Value, K, K) -- Returns (value, maxPolicyId, deepestTokenInMaxPolicy)
+generateConstrainedValueWithMaxPolicyAndQuantity numPolicies tokensPerPolicy qty g = do
   policyIds <- replicateM numPolicies (generateKey g)
   tokenNames <- replicateM tokensPerPolicy (generateKey g)
-
   let
-    qty :: Value.Quantity
-    qty = case Value.quantity (fromIntegral (maxBound :: Int64)) of
-      Just q -> q
-      Nothing -> error "generateConstrainedValueWithMaxPolicy: Int64 maxBound should be valid Quantity"
 
     -- Sort policy IDs to establish BST ordering
     sortedPolicyIds = sort policyIds
@@ -303,6 +382,17 @@ generateConstrainedValue numPolicies tokensPerPolicy g = do
   (value, _, _) <- generateConstrainedValueWithMaxPolicy numPolicies tokensPerPolicy g
   pure value
 
+generateConstrainedValueWithQuantity
+  :: (StatefulGen g m)
+  => Int -- Number of policies
+  -> Int -- Number of tokens per policy
+  -> Quantity
+  -> g
+  -> m Value
+generateConstrainedValueWithQuantity numPolicies tokensPerPolicy qty g = do
+  (value, _, _) <- generateConstrainedValueWithMaxPolicyAndQuantity numPolicies tokensPerPolicy qty g
+  pure value
+
 ----------------------------------------------------------------------------------------------------
 -- Other Generators --------------------------------------------------------------------------------
 
@@ -325,6 +415,43 @@ generateKey g = do
     Just key -> pure key
     Nothing  -> error "Internal error: maxKeyLen key should always be valid"
 
+-- | Generate either zero or maximum amount Integer values, the probability of each is 50%
+genZeroOrMaxAmount
+  :: (StatefulGen g m)
+  => g
+  -> Int
+  -- ^ Number of amounts to generate
+  -> m [Integer]
+genZeroOrMaxAmount gen n =
+  genZeroOrAmount gen n (maxBound :: Quantity)
+
+genZeroOrAmount
+  :: (StatefulGen g m)
+  => g
+  -> Int
+  -- ^ Number of amounts to generate
+  -> Quantity
+  -> m [Integer]
+genZeroOrAmount gen n qty =
+  replicateM n $ do
+    coinType <- uniformRM (0 :: Int, 1) gen
+    pure $ case coinType of
+      0 -> 0
+      1 -> unQuantity qty
+      _ -> error "genZeroOrMaxAmount: impossible"
+
+genBoundedProduct
+  :: (StatefulGen g m)
+  => g
+  -> m (Integer, Integer)
+genBoundedProduct gen = do
+  i1 <- uniformRM (0, sqrtMax) gen
+  i2 <- uniformRM (0, sqrtMax) gen
+  pure (i1, i2)
+
+sqrtMax :: Integer
+sqrtMax = floor . sqrt . fromIntegral $ unQuantity (maxBound :: Quantity)
+
 ----------------------------------------------------------------------------------------------------
 -- Helper Functions --------------------------------------------------------------------------------
 
@@ -341,3 +468,13 @@ unsafeFromBuiltinResult = \case
   BuiltinSuccess x -> x
   BuiltinSuccessWithLogs _ x -> x
   BuiltinFailure _ err -> error $ "BuiltinResult failed: " <> show err
+
+-- | Abstracted runner for computations using stateful random generator 'StdGen'
+runBenchGen :: StdGen -> (StateGenM StdGen -> State StdGen a) -> a
+runBenchGen gen ma = runStateGen_ gen \g -> ma g
+
+mkQuantity :: Integer -> Value.Quantity
+mkQuantity qty = case Value.quantity qty of
+  Just q  -> q
+  Nothing -> error "mkQuantity: out of bounds user supplied integer as quantity"
+

plutus-core/cost-model/budgeting-bench/Common.hs

@@ -431,3 +431,36 @@ createThreeTermBuiltinBenchWithWrappers (wrapX, wrapY, wrapZ) fun tys xs ys zs =
       [mkBM x y z | z <- zs] | y <- ys] | x <- xs]
   where mkBM x y z = benchDefault (showMemoryUsage (wrapZ z)) $ mkApp3 fun tys x y z
 
+{- See Note [Adjusting the memory usage of arguments of costing benchmarks]. -}
+createFourTermBuiltinBenchElementwiseWithWrappers
+  :: ( fun ~ DefaultFun
+     , uni ~ DefaultUni
+     , uni `HasTermLevel` a
+     , uni `HasTermLevel` b
+     , uni `HasTermLevel` c
+     , uni `HasTermLevel` d
+     , ExMemoryUsage a'
+     , ExMemoryUsage b'
+     , ExMemoryUsage c'
+     , ExMemoryUsage d'
+     , NFData a
+     , NFData b
+     , NFData c
+     , NFData d
+     )
+  => (a -> a', b -> b', c -> c', d -> d')
+  -> fun
+  -> [Type tyname uni ()]
+  -> [(a,b,c,d)]
+  -> Benchmark
+createFourTermBuiltinBenchElementwiseWithWrappers (wrapW, wrapX, wrapY, wrapZ) fun tys inputs =
+  bgroup (show fun) $
+  fmap
+  (\(w, x, y, z) ->
+     bgroup (showMemoryUsage $ wrapW w)
+     [bgroup (showMemoryUsage $ wrapX x)
+      [bgroup (showMemoryUsage $ wrapY y) [mkBM w x y z]]
+     ]
+  )
+  inputs
+  where mkBM w x y z = benchDefault (showMemoryUsage $ wrapZ z) $ mkApp4 fun tys w x y z

plutus-core/cost-model/budgeting-bench/Main.hs

@@ -48,20 +48,20 @@ main = do
   criterionMainWith
        Start
        defaultConfig $
-           Benchmarks.Bitwise.makeBenchmarks
-        <> Benchmarks.Bool.makeBenchmarks        gen
-        <> Benchmarks.ByteStrings.makeBenchmarks gen
-        <> Benchmarks.Crypto.makeBenchmarks      gen
-        <> Benchmarks.Data.makeBenchmarks        gen
-        <> Benchmarks.Integers.makeBenchmarks    gen
-        <> Benchmarks.Lists.makeBenchmarks       gen
-        <> Benchmarks.Arrays.makeBenchmarks      gen
-        <> Benchmarks.Misc.makeBenchmarks        gen
-        <> Benchmarks.Pairs.makeBenchmarks       gen
-        <> Benchmarks.Strings.makeBenchmarks     gen
-        <> Benchmarks.Tracing.makeBenchmarks     gen
-        <> Benchmarks.Unit.makeBenchmarks        gen
-        <> Benchmarks.Values.makeBenchmarks      gen
+            Benchmarks.Bitwise.makeBenchmarks
+         <> Benchmarks.Bool.makeBenchmarks        gen
+         <> Benchmarks.ByteStrings.makeBenchmarks gen
+         <> Benchmarks.Crypto.makeBenchmarks      gen
+         <> Benchmarks.Data.makeBenchmarks        gen
+         <> Benchmarks.Integers.makeBenchmarks    gen
+         <> Benchmarks.Lists.makeBenchmarks       gen
+         <> Benchmarks.Arrays.makeBenchmarks      gen
+         <> Benchmarks.Misc.makeBenchmarks        gen
+         <> Benchmarks.Pairs.makeBenchmarks       gen
+         <> Benchmarks.Strings.makeBenchmarks     gen
+         <> Benchmarks.Tracing.makeBenchmarks     gen
+         <> Benchmarks.Unit.makeBenchmarks        gen
+         <> Benchmarks.Values.makeBenchmarks      gen
 
   {- Run the nop benchmarks with a large time limit (30 seconds) in an attempt to
      get accurate results. -}

plutus-core/cost-model/create-cost-model/BuiltinMemoryModels.hs

@@ -181,5 +181,7 @@ builtinMemoryModels = BuiltinCostModelBase
   , paramValueContains                   = Id $ ModelTwoArgumentsConstantCost 32
   , paramValueData                       = Id $ ModelOneArgumentConstantCost 32
   , paramUnValueData                     = Id $ ModelOneArgumentConstantCost 32
+  , paramInsertCoin                      = Id $ ModelFourArgumentsConstantCost 1
+  , paramUnionValue                      = Id $ ModelTwoArgumentsConstantCost 1
   }
   where identityFunction = OneVariableLinearFunction 0 1

plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs

@@ -136,6 +136,8 @@ builtinCostModelNames = BuiltinCostModelBase
   , paramValueContains                   = "valueContainsModel"
   , paramValueData                       = "valueDataModel"
   , paramUnValueData                     = "unValueDataModel"
+  , paramInsertCoin                      = "insertCoinModel"
+  , paramUnionValue                      = "unionValueModel"
   }
 
 
@@ -289,6 +291,8 @@ createBuiltinCostModel bmfile rfile = do
   paramValueContains                   <- getParams readCF2 paramValueContains
   paramValueData                       <- getParams readCF1 paramValueData
   paramUnValueData                     <- getParams readCF1 paramUnValueData
+  paramInsertCoin                      <- getParams readCF4 paramInsertCoin
+  paramUnionValue                      <- getParams readCF2 paramUnionValue
 
   pure $ BuiltinCostModelBase {..}
 
@@ -362,6 +366,12 @@ readTwoVariableLinearFunction var1 var2 e = do
   slopeY <- Slope <$> getCoeff var2 e
   pure $ TwoVariableLinearFunction intercept slopeX slopeY
 
+readSquareOfTwoVariableSumFunction :: MonadR m => String -> String -> SomeSEXP (Region m) -> m SquareOfTwoVariableSumFunction
+readSquareOfTwoVariableSumFunction var1 var2 e = do
+  c00 <- Coefficient00 <$> getCoeff "(Intercept)" e
+  c11 <- Coefficient11 <$> getCoeff (printf "I((%s + %s)^2)" var1 var2) e
+  pure $ SquareOfTwoVariableSumFunction c00 c11
+
 readTwoVariableQuadraticFunction :: MonadR m => String -> String -> SomeSEXP (Region m) -> m TwoVariableQuadraticFunction
 readTwoVariableQuadraticFunction var1 var2 e = do
   minVal <- getExtraParam "minimum" e
@@ -431,6 +441,7 @@ readCF2AtType ty e = do
     "const_off_diagonal"   -> ModelTwoArgumentsConstOffDiagonal   <$> readOneVariableFunConstOr e
     "quadratic_in_y"       -> ModelTwoArgumentsQuadraticInY       <$> readOneVariableQuadraticFunction "y_mem" e
     "quadratic_in_x_and_y" -> ModelTwoArgumentsQuadraticInXAndY   <$> readTwoVariableQuadraticFunction "x_mem" "y_mem" e
+    "square_of_sum" -> ModelTwoArgumentsSquareOfSum <$> readSquareOfTwoVariableSumFunction "x_mem" "y_mem" e
     _                      -> error $ "Unknown two-variable model type: " ++ ty
 
 readCF2 :: MonadR m => SomeSEXP (Region m) -> m ModelTwoArguments
@@ -452,6 +463,14 @@ readCF3 e = do
     "exp_mod_cost"                -> ModelThreeArgumentsExpModCost            <$> readExpModCostingFunction "y_mem" "z_mem" e
     _                             -> error $ "Unknown three-variable model type: " ++ ty
 
+readCF4 :: MonadR m => SomeSEXP (Region m) -> m ModelFourArguments
+readCF4 e = do
+  ty <- getType e
+  case ty of
+    "constant_cost" -> ModelFourArgumentsConstantCost <$> getConstant e
+    "linear_in_w"   -> ModelFourArgumentsLinearInW <$> readOneVariableLinearFunction "w_mem" e
+    _               -> error $ "Unknown four-variable model type: " ++ ty
+
 readCF6 :: MonadR m => SomeSEXP (Region m) -> m ModelSixArguments
 readCF6 e = do
   ty <- getType e