enable gas log on computeGasCommit (#1037)

Co-authored-by: John Wiegley <[email protected]>

src/Pact/Gas.hs

@@ -31,8 +31,8 @@ computeGas i args = do
   let
     (info,name) = either id (_faInfo &&& _faName) i
     g1 = runGasModel _geGasModel name args
-  evalLogGas %= fmap ((renderCompactText' (pretty name <> ":" <> pretty args),g1):)
   let gUsed = g0 + g1
+  evalLogGas %= fmap ((renderCompactText' (pretty name <> ":" <> pretty args <> ":currTotalGas=" <> pretty gUsed),g1):)
   putGas gUsed
   if gUsed > fromIntegral _geGasLimit then
     throwErr GasError info $ "Gas limit (" <> pretty _geGasLimit <> ") exceeded: " <> pretty gUsed
@@ -67,7 +67,17 @@ computeGasNonCommit = computeGasNoLog (const (pure ()))
 
 -- | See: ComputeGasNoLog, save currently used `evalGas`
 computeGasCommit :: Info -> Text -> GasArgs -> Eval e Gas
-computeGasCommit = computeGasNoLog putGas
+computeGasCommit info name args = do
+  GasEnv {..} <- view eeGasEnv
+  g0 <- getGas
+  let !g1 = runGasModel _geGasModel name args
+      !gUsed = g0 + g1
+  evalLogGas %= fmap ((renderCompactText' (pretty name <> ":" <> pretty args <> ":currTotalGas=" <> pretty gUsed),g1):)
+  putGas gUsed
+  if gUsed > fromIntegral _geGasLimit then
+    throwErr GasError info $ "Gas limit (" <> pretty _geGasLimit <> ") exceeded: " <> pretty gUsed
+    else return gUsed
+
 
 -- | Pre-compute gas for some application before some action.
 computeGas' :: Gas -> FunApp -> GasArgs -> Eval e a -> Eval e (Gas,a)

src/Pact/Gas/Table.hs

@@ -234,7 +234,8 @@ tableGasModel gasConfig =
           Defpact -> (_gasCostConfig_defPactCost gasConfig) * _gasCostConfig_functionApplicationCost gasConfig
           _ -> _gasCostConfig_functionApplicationCost gasConfig
         GIntegerOpCost i j ->
-          intCost i + intCost j
+          intCost (fst i) + intCost (fst j)
+        GDecimalOpCost _ _ -> 0
         GMakeList v -> expLengthPenalty v
         GSort len -> expLengthPenalty len
         GDistinct len -> expLengthPenalty len

src/Pact/Native/Ops.hs

@@ -134,10 +134,13 @@ powDef = defRNative "^" pow coerceBinNum ["(^ 2 3)"] "Raise X to Y power."
 #if defined(ghcjs_HOST_OS)
     binop "^" (\a' b' -> liftDecF i (**) a' b') intPow i as
 #else
-    decimalPow <- ifExecutionFlagSet' FlagDisableNewTrans (liftDecF i (**)) (liftDecF i trans_pow)
+    decimalPow <- ifExecutionFlagSet' FlagDisableNewTrans (liftDecPowF i (**)) (liftDecPowF i trans_pow)
     binop "^" decimalPow intPow i as
 #endif
     where
+    liftDecPowF fi f lop rop = do
+      _ <- computeGasCommit def "" (GDecimalOpCost lop rop)
+      liftDecF fi f lop rop
     oldIntPow  b' e = do
       when (b' < 0) $ evalError' i $ "Integral power must be >= 0" <> ": " <> pretty (a,b)
       liftIntegerOp (^) b' e
@@ -161,7 +164,14 @@ powDef = defRNative "^" pow coerceBinNum ["(^ 2 3)"] "Raise X to Y power."
 
 twoArgIntOpGas :: Integer -> Integer -> Eval e Gas
 twoArgIntOpGas loperand roperand =
-  computeGasCommit def "" (GIntegerOpCost loperand roperand)
+  computeGasCommit def "" (GIntegerOpCost (loperand, Nothing) (roperand, Nothing))
+
+twoArgDecOpGas :: Decimal -> Decimal -> Eval e Gas
+twoArgDecOpGas loperand roperand =
+  computeGasCommit def ""
+  (GIntegerOpCost
+    (decimalMantissa loperand, Just (fromIntegral (decimalPlaces loperand)))
+    (decimalMantissa roperand, Just (fromIntegral (decimalPlaces roperand))))
 
 legalLogArg :: Literal -> Bool
 legalLogArg = \case
@@ -178,6 +188,9 @@ litGt0 = \case
 logDef :: NativeDef
 logDef = defRNative "log" log' coerceBinNum ["(log 2 256)"] "Log of Y base X."
   where
+  liftLogDec fi f a b = do
+    _ <- computeGasCommit def "" (GDecimalOpCost a b)
+    liftDecF fi f a b
   log' :: RNativeFun e
   log' fi as@[TLiteral base _,TLiteral v _] = do
     unlessExecutionFlagSet FlagDisablePact43 $
@@ -190,7 +203,7 @@ logDef = defRNative "log" log' coerceBinNum ["(log 2 256)"] "Log of Y base X."
           as
 #else
     decimalLogBase <-
-      ifExecutionFlagSet' FlagDisableNewTrans (liftDecF fi logBase) (liftDecF fi trans_log)
+      ifExecutionFlagSet' FlagDisableNewTrans (liftLogDec fi logBase) (liftLogDec fi trans_log)
     integerLogBase <-
       ifExecutionFlagSet' FlagDisableNewTrans (liftIntF fi logBase) (liftIntF fi trans_log)
     binop "log" decimalLogBase integerLogBase fi as
@@ -458,7 +471,7 @@ liftIntegerOp f a b = do
 
 liftDecimalOp :: (Decimal -> Decimal -> Decimal) -> Decimal -> Decimal -> Eval e Decimal
 liftDecimalOp f a b = do
-  unlessExecutionFlagSet FlagDisablePact43 $ twoArgIntOpGas (decimalMantissa a) (decimalMantissa b)
+  unlessExecutionFlagSet FlagDisablePact43 $ twoArgDecOpGas a b
   pure (f a b)
 
 

src/Pact/Types/Gas.hs

@@ -38,6 +38,7 @@ import Data.Aeson
 import Data.Text (Text, unpack)
 import Data.Aeson.Types (Parser)
 import Data.Serialize
+import Data.Decimal
 
 import GHC.Generics
 
@@ -149,8 +150,10 @@ data GasArgs
   -- ^ The cost of the in-memory representation of the module
   | GPrincipal !Int
   -- ^ the cost of principal creation and validation
-  | GIntegerOpCost !Integer Integer
+  | GIntegerOpCost !(Integer, Maybe Integer) !(Integer, Maybe Integer)
   -- ^ Integer costs
+  | GDecimalOpCost !Decimal !Decimal
+  -- ^ Decimal costs
   | GMakeList2 !Integer !(Maybe Integer)
   -- ^ List versioning 2
   | GZKArgs ZKArg
@@ -204,6 +207,7 @@ instance Pretty GasArgs where
     GModuleMemory i -> "GModuleMemory: " <> pretty i
     GPrincipal i -> "GPrincipal: " <> pretty i
     GIntegerOpCost i j -> "GIntegerOpCost:" <> pretty i <> colon <> pretty j
+    GDecimalOpCost i j -> "GDecimalOpCost:" <> pretty (show i) <> colon <> pretty (show j)
     GMakeList2 i k -> "GMakeList2:" <> pretty i <> colon <> pretty k
     GZKArgs arg -> "GZKArgs:" <> pretty arg