diff --git a/src/Pact/Gas.hs b/src/Pact/Gas.hs index 03d6a214f..eea7ff301 100644 --- a/src/Pact/Gas.hs +++ b/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) diff --git a/src/Pact/Gas/Table.hs b/src/Pact/Gas/Table.hs index 514990c9f..5d98f9081 100644 --- a/src/Pact/Gas/Table.hs +++ b/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 diff --git a/src/Pact/Native/Ops.hs b/src/Pact/Native/Ops.hs index 89bec0538..7ef84b35c 100644 --- a/src/Pact/Native/Ops.hs +++ b/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) diff --git a/src/Pact/Types/Gas.hs b/src/Pact/Types/Gas.hs index b3ddbfc1b..6fcaa03dd 100644 --- a/src/Pact/Types/Gas.hs +++ 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