BuiltinValue: insertCoin and unionValue costing

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

@@ -0,0 +1,115 @@
+module Benchmarks.Values (
+    makeBenchmarks,
+) where
+
+import Prelude
+
+import Common
+
+import PlutusCore (DefaultFun (InsertCoin, LookupCoin, UnValueData, ValueContains, ValueData))
+import PlutusCore.Value (Value)
+import PlutusCore.Value qualified as Value
+
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State.Strict (State, StateT, evalState, gets, modify)
+import Criterion.Main (Benchmark)
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Data.Text qualified as Text
+import Data.Text.Encoding (encodeUtf8)
+import Data.Word (Word8)
+import System.Random.Stateful (StateGenM, StatefulGen, StdGen, UniformRange (uniformRM),
+                               runStateGenT_, uniformByteStringM)
+
+makeBenchmarks :: StdGen -> [Benchmark]
+makeBenchmarks gen =
+    [ benchInsertCoin gen
+    -- , benchUnionValue gen
+    ]
+
+newtype PolicyId = PolicyId ByteString
+newtype TokenName = TokenName ByteString
+newtype Amount = Amount Integer
+type Counter = Integer
+
+data GenState = GenState
+    { policyIdCounter  :: Counter
+    , tokenNameCounter :: Counter
+    }
+
+type BenchState = StateT StdGen (State GenState)
+
+-- | An insertCoin benchmark is a concrete set of arguments we apply to the
+-- InsertCoin builtin function to measure its runtime cost.
+data InsertCoinBenchmark = InsertCoinBenchmark
+    { icPolicyId  :: PolicyId
+    , icTokenName :: TokenName
+    , icAmount    :: Amount
+    , icValue     :: Value
+    }
+
+icToRawTuple :: InsertCoinBenchmark -> (ByteString, ByteString, Integer, Value)
+icToRawTuple (InsertCoinBenchmark (PolicyId p) (TokenName t) (Amount a) v) = (p, t, a, v)
+
+benchInsertCoin :: StdGen -> Benchmark
+benchInsertCoin gen =
+    createFourTermBuiltinBenchElementwiseWithWrappers
+        (id, id, id, id) -- TODO: use proper wrappers
+        InsertCoin
+        []
+        (icToRawTuple <$> insertCoinBenchGen gen)
+
+-- | Generate a set of benchmarks for the InsertCoin builtin function.
+-- It includes the following scenarios:
+--   1. Inserting into an empty Value.
+--   2. Inserting a new TokenName into an existing PolicyId. Randomly extracting a PolicyId from the Value.
+--   3. Inserting into an existing TokenName. Randomly extracting a (PolicyId, TokenName) pair from the Value.
+--   4. Inserting a new PolicyId.
+--   5. Deleting a TokenName by inserting a 0 amount. Randomly extracting a (PolicyId, TokenName) pair from the Value.
+--   6. Deleting a PolicyId by inserting a 0 amount into its last TokenName. Should generate a Value with multiple such PolicyIds, and randomly picking which PolicyId to delete.
+-- We're interested in the worst case performance, so we'll use the largest key values possible.
+-- We should also run randomized benchmarks, where we insert random values into random Values.
+-- We actually want to see how the performance scales with the size of the Value, so we should generate Values of varying sizes.
+-- We want to make sure we are also hitting the worst case scenarios and various edge cases.
+insertCoinBenchGen
+    :: StdGen
+    -> [InsertCoinBenchmark]
+insertCoinBenchGen g = flip evalState (GenState 0 0) $ runStateGenT_ g $ \gen -> do
+    policyId <- newPolicyId gen
+    tokenName <- newTokenName gen
+    amount <- uniformAmount gen
+    let emptyValueBench = InsertCoinBenchmark policyId tokenName amount Value.empty
+    pure [emptyValueBench]
+
+-- | Generate a unique PolicyId on a uniform distribution. Note that the size of the
+-- generated bytestring is going to be larger than Value.maxKeyLen, because we
+-- append a counter integer to ensure uniqueness. This is acceptable for benchmarking
+-- purposes, as we're interested in the worst-case performance.
+newPolicyId :: StateGenM StdGen -> BenchState PolicyId
+newPolicyId gen = do
+    bs <- uniformByteStringM Value.maxKeyLen gen
+    c <- lift $ gets policyIdCounter
+    let newbs = BS.append bs (encodeUtf8 . Text.pack . show $ c)
+    lift $ modify $ \s -> s { policyIdCounter = c + 1 }
+    pure $ PolicyId newbs
+
+-- | Generate a unique TokenName on a uniform distribution. Note that the size of the
+-- generated bytestring is going to be larger than Value.maxKeyLen, because we
+-- append a counter integer to ensure uniqueness. This is acceptable for benchmarking
+-- purposes, as we're interested in the worst-case performance.
+-- Actually, this wouldn't be acceptable if we were to measure based on the size of the
+-- keys, because we would want to view how key size affects performance!
+newTokenName :: StateGenM StdGen -> BenchState TokenName
+newTokenName gen = do
+    bs <- uniformByteStringM Value.maxKeyLen gen
+    c <- lift $ gets tokenNameCounter
+    let newbs = BS.append bs (encodeUtf8 . Text.pack . show $ c)
+    lift $ modify $ \s -> s { tokenNameCounter = c + 1 }
+    pure $ TokenName newbs
+
+uniformAmount :: StateGenM StdGen -> BenchState Amount
+uniformAmount gen =
+    Amount <$> uniformRM (0, 100) gen -- TODO: tweak the range
+
+newValue :: StateGenM StdGen -> BenchState Value
+newValue gen = undefined

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/create-cost-model/BuiltinMemoryModels.hs

@@ -176,5 +176,8 @@ builtinMemoryModels = BuiltinCostModelBase
   , paramLengthOfArray                   = Id $ ModelOneArgumentConstantCost 10
   , paramListToArray                     = Id $ ModelOneArgumentLinearInX $ OneVariableLinearFunction 7 1
   , paramIndexArray                      = Id $ ModelTwoArgumentsConstantCost 32
+  -- Builtin values
+  , paramInsertCoin                      = Id $ ModelFourArgumentsConstantCost 1
+  , paramUnionValue                      = Id $ ModelTwoArgumentsConstantCost 1
   }
   where identityFunction = OneVariableLinearFunction 0 1

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

@@ -131,6 +131,9 @@ builtinCostModelNames = BuiltinCostModelBase
   , paramLengthOfArray                   = "lengthOfArrayModel"
   , paramListToArray                     = "listToArrayModel"
   , paramIndexArray                      = "indexArrayModel"
+  -- Builtin values
+  , paramInsertCoin                      = "insertCoinModel"
+  , paramUnionValue                      = "unionValueModel"
   }
 
 
@@ -279,6 +282,9 @@ createBuiltinCostModel bmfile rfile = do
   paramLengthOfArray                   <- getParams readCF1 paramLengthOfArray
   paramListToArray                     <- getParams readCF1 paramListToArray
   paramIndexArray                      <- getParams readCF2 paramIndexArray
+  -- Builtin values
+  paramInsertCoin                      <- getParams readCF4 paramInsertCoin
+  paramUnionValue                      <- getParams readCF2 paramUnionValue
 
   pure $ BuiltinCostModelBase {..}
 
@@ -442,6 +448,13 @@ 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
+    _               -> error $ "Unknown four-variable model type: " ++ ty
+
 readCF6 :: MonadR m => SomeSEXP (Region m) -> m ModelSixArguments
 readCF6 e = do
   ty <- getType e

plutus-core/cost-model/data/builtinCostModelA.json

@@ -1205,5 +1205,25 @@
             "arguments": 4,
             "type": "constant_cost"
         }
+    },
+    "insertCoin": {
+        "cpu": {
+            "arguments": 0,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 0,
+            "type": "constant_cost"
+        }
+    },
+    "unionValue": {
+            "cpu": {
+            "arguments": 0,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 0,
+            "type": "constant_cost"
+        }
     }
 }

plutus-core/cost-model/data/builtinCostModelB.json

@@ -1205,5 +1205,25 @@
             "arguments": 4,
             "type": "constant_cost"
         }
+    },
+    "insertCoin": {
+        "cpu": {
+            "arguments": 1000,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 10,
+            "type": "constant_cost"
+        }
+    },
+    "unionValue": {
+        "cpu": {
+            "arguments": 1000,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 10,
+            "type": "constant_cost"
+        }
     }
 }

plutus-core/cost-model/data/builtinCostModelC.json

@@ -1223,5 +1223,25 @@
             "arguments": 4,
             "type": "constant_cost"
         }
+    }, 
+    "insertCoin": {
+        "cpu": {
+            "arguments": 1000,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 10,
+            "type": "constant_cost"
+        }
+    },
+    "unionValue": {
+        "cpu": {
+            "arguments": 1000,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 10,
+            "type": "constant_cost"
+        }
     }
 }

plutus-core/plutus-core.cabal

@@ -95,10 +95,10 @@ library
     Data.MultiSet.Lens
     Data.Version.Extras
     PlutusCore
-    PlutusCore.AstSize
     PlutusCore.Analysis.Definitions
     PlutusCore.Annotation
     PlutusCore.Arity
+    PlutusCore.AstSize
     PlutusCore.Bitwise
     PlutusCore.Builtin
     PlutusCore.Builtin.Debug
@@ -515,11 +515,11 @@ library plutus-ir
   hs-source-dirs:  plutus-ir/src
   exposed-modules:
     PlutusIR
-    PlutusIR.AstSize
     PlutusIR.Analysis.Builtins
     PlutusIR.Analysis.Dependencies
     PlutusIR.Analysis.RetainedSize
     PlutusIR.Analysis.VarInfo
+    PlutusIR.AstSize
     PlutusIR.Check.Uniques
     PlutusIR.Compiler
     PlutusIR.Compiler.Datatype
@@ -935,6 +935,7 @@ executable cost-model-budgeting-bench
     Benchmarks.Strings
     Benchmarks.Tracing
     Benchmarks.Unit
+    Benchmarks.Values
     Common
     CriterionExtensions
     Generators
@@ -958,6 +959,7 @@ executable cost-model-budgeting-bench
     , random
     , text
     , time
+    , transformers
     , vector
 
 -- This reads CSV data generated by cost-model-budgeting-bench, uses R to build

plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs

@@ -2052,7 +2052,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
           {-# INLINE insertCoinDenotation #-}
        in makeBuiltinMeaning
             insertCoinDenotation
-            (runCostingFunFourArguments . unimplementedCostingFun)
+            (runCostingFunFourArguments . paramInsertCoin)
 
     toBuiltinMeaning _semvar LookupCoin =
       let lookupCoinDenotation :: ByteString -> ByteString -> Value -> Integer
@@ -2068,7 +2068,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
           {-# INLINE unionValueDenotation #-}
        in makeBuiltinMeaning
             unionValueDenotation
-            (runCostingFunTwoArguments . unimplementedCostingFun)
+            (runCostingFunTwoArguments . paramUnionValue)
 
     toBuiltinMeaning _semvar ValueContains =
       let valueContainsDenotation :: Value -> Value -> BuiltinResult Bool

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs

@@ -193,6 +193,9 @@ data BuiltinCostModelBase f =
     , paramLengthOfArray                   :: f ModelOneArgument
     , paramListToArray                     :: f ModelOneArgument
     , paramIndexArray                      :: f ModelTwoArguments
+    -- Builtin values
+    , paramInsertCoin                      :: f ModelFourArguments
+    , paramUnionValue                      :: f ModelTwoArguments
     }
     deriving stock (Generic)
     deriving anyclass (FunctorB, TraversableB, ConstraintsB)

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs

@@ -238,6 +238,9 @@ unitCostTwoArguments   =  CostingFun (ModelTwoArgumentsConstantCost 1) (ModelTwo
 unitCostThreeArguments :: CostingFun ModelThreeArguments
 unitCostThreeArguments =  CostingFun (ModelThreeArgumentsConstantCost 1) (ModelThreeArgumentsConstantCost 0)
 
+unitCostFourArguments :: CostingFun ModelFourArguments
+unitCostFourArguments  =  CostingFun (ModelFourArgumentsConstantCost 1) (ModelFourArgumentsConstantCost 0)
+
 unitCostSixArguments :: CostingFun ModelSixArguments
 unitCostSixArguments   =  CostingFun (ModelSixArgumentsConstantCost 1) (ModelSixArgumentsConstantCost 0)
 
@@ -355,6 +358,9 @@ unitCostBuiltinCostModel = BuiltinCostModelBase
     , paramLengthOfArray                   = unitCostOneArgument
     , paramListToArray                     = unitCostOneArgument
     , paramIndexArray                      = unitCostTwoArguments
+    -- Builtin values
+    , paramInsertCoin                      = unitCostFourArguments
+    , paramUnionValue                      = unitCostTwoArguments
     }
 
 unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann)