Tweak cost of running concat

src/Pact/Gas/Table.hs

@@ -39,6 +39,9 @@ data GasCostConfig = GasCostConfig
   , _gasCostConfig_sortFactor :: Gas
   , _gasCostConfig_distinctFactor :: Gas
   , _gasCostConfig_concatenationFactor :: Gas
+  , _gasCostConfig_textConcatenationFactorOffset :: MilliGas -- up-front cost of text concatenation
+  , _gasCostConfig_textConcatenationFactorStringLen :: MilliGas -- additional cost of concatenation per character in the average string
+  , _gasCostConfig_textConcatenationFactorStrings :: MilliGas -- additional cost of concatenation per list item
   , _gasCostConfig_moduleCost :: Gas
   , _gasCostConfig_moduleMemberCost :: Gas
   , _gasCostConfig_useModuleCost :: Gas
@@ -58,6 +61,9 @@ defaultGasConfig = GasCostConfig
   , _gasCostConfig_sortFactor = 1
   , _gasCostConfig_distinctFactor = 1
   , _gasCostConfig_concatenationFactor = 1  -- TODO benchmark
+  , _gasCostConfig_textConcatenationFactorOffset = MilliGas 50000
+  , _gasCostConfig_textConcatenationFactorStringLen = MilliGas 20
+  , _gasCostConfig_textConcatenationFactorStrings = MilliGas 40
   , _gasCostConfig_moduleCost = 1        -- TODO benchmark
   , _gasCostConfig_moduleMemberCost = 1
   , _gasCostConfig_useModuleCost = 1     -- TODO benchmark
@@ -248,10 +254,21 @@ tableGasModel gasConfig =
           Just cs -> _gasCostConfig_selectColumnCost gasConfig * fromIntegral (length cs)
         GSortFieldLookup n ->
           gasToMilliGas $ fromIntegral n * _gasCostConfig_sortFactor gasConfig
-        GConcatenation i j ->
-          gasToMilliGas $ fromIntegral (i + j) * _gasCostConfig_concatenationFactor gasConfig
-        GFoldDB ->
-          gasToMilliGas $ _gasCostConfig_foldDBCost gasConfig
+        GConcatenation i j -> gasToMilliGas $
+          fromIntegral (i + j) * _gasCostConfig_concatenationFactor gasConfig
+        GTextConcatenation nChars nStrings ->
+          let
+            MilliGas offsetCost = _gasCostConfig_textConcatenationFactorOffset gasConfig
+            MilliGas charCost = _gasCostConfig_textConcatenationFactorStringLen gasConfig
+            MilliGas stringCost = _gasCostConfig_textConcatenationFactorStrings gasConfig
+
+            costForAverageStringLength =
+              (fromIntegral nChars  * charCost) `div` fromIntegral nStrings
+            costForNumberOfStrings =
+              fromIntegral nStrings * stringCost
+          in
+           MilliGas $ offsetCost + costForAverageStringLength + costForNumberOfStrings
+        GFoldDB -> gasToMilliGas $ _gasCostConfig_foldDBCost gasConfig
         GPostRead r -> gasToMilliGas $ case r of
           ReadData cols -> _gasCostConfig_readColumnCost gasConfig * fromIntegral (Map.size (_objectMap $ _rdData cols))
           ReadKey _rowKey -> _gasCostConfig_readColumnCost gasConfig

src/Pact/Native.hs

@@ -1259,15 +1259,35 @@ identity _ [a'] = return a'
 identity i as = argsError i as
 
 concat' :: GasRNativeFun e
-concat' i [TList ls _ _] = computeGas' i (GMakeList $ fromIntegral $ V.length ls) $ let
-  -- Use GMakeList because T.concat is O(n) on the number of strings in the list
-  ls' = V.toList ls
-  concatTextList = flip TLiteral def . LString . T.concat
-  in fmap concatTextList $ forM ls' $ \case
-    TLitString s -> return s
-    t -> isOffChainForkedError FlagDisablePact47 >>= \case
-      OffChainError -> evalError' i $ "concat: expecting list of strings: " <> pretty t
-      OnChainError -> evalError' i $ "concat: expected list of strings, received value of type: " <> pretty (typeof' t)
+concat' i [TList ls _ _] = do
+
+  disablePact48 <- isExecutionFlagSet FlagDisablePact48
+  let concatGasCost =
+        if disablePact48
+        then
+          -- Prior to pact-4.8, gas cost is proportional to the number of
+          -- strings being concatenated.
+          GMakeList $ fromIntegral $ V.length ls
+        else
+          -- Beginning with pact-4.8, gas cost in proportional to the number of
+          -- characters being concatinated and the length of the list.
+          let nChars = sum $ termLen <$> ls
+                where
+                  termLen t = case t of
+                    TLitString s -> T.length s
+                    _ -> 0
+              nStrings = V.length ls
+          in
+          GTextConcatenation nChars nStrings
+  computeGas' i concatGasCost $
+    let
+      ls' = V.toList ls
+      concatTextList = flip TLiteral def . LString . T.concat
+    in fmap concatTextList $ forM ls' $ \case
+      TLitString s -> return s
+      t -> isOffChainForkedError FlagDisablePact47 >>= \case
+        OffChainError -> evalError' i $ "concat: expecting list of strings: " <> pretty t
+        OnChainError -> evalError' i $ "concat: expected list of strings, received value of type: " <> pretty (typeof' t)
 concat' i as = argsError i as
 
 -- | Converts a string to a vector of single character strings

src/Pact/Types/Gas.hs

@@ -137,7 +137,10 @@ data GasArgs
   | GSortFieldLookup !Int
   -- ^ Cost of sorting by lookup fields
   | GConcatenation !Int !Int
-  -- ^ Cost of concatenating two strings, lists, and objects
+  -- ^ Cost of concatenating two strings before pact 4.8, lists, and objects
+  | GTextConcatenation !Int !Int
+  -- ^ Cost of concatenating a list of strings with the given total character
+  -- count and list length after pact 4.8
   | GUnreduced ![Term Ref]
   -- ^ Cost of using a native function
   | GPostRead !ReadValue
@@ -204,6 +207,7 @@ instance Pretty GasArgs where
     GSelect {} -> "GSelect"
     GSortFieldLookup i -> "GSortFieldLookup:" <> pretty i
     GConcatenation i j -> "GConcatenation:" <> pretty i <> colon <> pretty j
+    GTextConcatenation nChars nStrings -> "GTextConcatenation:" <> pretty nChars <> colon <> pretty nStrings
     GUnreduced {} -> "GUnreduced"
     GPostRead rv -> "GPostRead:" <> pretty rv
     GPreWrite wv szVer -> "GWrite:" <> pretty wv <> colon <> pretty szVer

tests/GasModelSpec.hs

@@ -166,7 +166,7 @@ runTest t = runGasUnitTests t run run
       let
         flags = mkExecutionConfig
                [ FlagDisableInlineMemCheck, FlagDisablePactEvents
-               , FlagDisablePact43, FlagDisablePact44, FlagDisablePact45]
+               , FlagDisablePact43, FlagDisablePact44, FlagDisablePact45, FlagDisablePact48]
         r' = set eeExecutionConfig flags r
       pure (r', s)
 

tests/pact/gas.repl

@@ -798,3 +798,34 @@ d.G3
 (str-to-list "0123456789")
 (expect "gas of str-to-list post-fork" 11 (env-gas))
 (commit-tx)
+
+
+; Test that `concat` is gassed by the number of characters
+; at pact-4.8.
+(begin-tx)
+(env-gaslimit 1000000)
+(module m G
+  (defcap G () true)
+  (defun ten_x_string (n)
+      (fold (lambda (acc unused) (+ acc "aaaaaaaaaa")) "" (enumerate 1 n)))
+  (defconst strings_1000_1000:[string] (make-list 1000 (ten_x_string 100)))
+  (defconst strings_1000_2000:[string] (make-list 2000 (ten_x_string 100)))
+  (defconst strings_2000_1000:[string] (make-list 1000 (ten_x_string 200)))
+  )
+
+; ============================================================ ;
+;; TEST: cost of running concat on large strings.
+;;
+(env-gas 0)
+(concat strings_1000_1000)
+(expect "calling (concat strings_1000_1000)" 111 (env-gas))
+
+(env-gas 0)
+(concat strings_2000_1000)
+(expect "calling (concat strings_2000_1000)" 131 (env-gas))
+
+(env-gas 0)
+(concat strings_1000_2000)
+(expect "calling (concat strings_1000_2000)" 151 (env-gas))
+
+(commit-tx)