make evaluate functions take a gasEnv

pact-request-api/Pact/Core/Command/Server.hs

@@ -303,7 +303,8 @@ computeResultAndUpdateState runtime requestKey cmd =
             , mdSigners = signer
             , mdVerifiers = maybe [] (fmap void) mverif
             }
-      evalExec (RawCode (_pcCode code)) Transactional (_srDbEnv runtime) (_srSPVSupport runtime) freeGasModel GasLogsDisabled mempty SimpleNamespacePolicy
+      ge <- mkFreeGasEnv GasLogsDisabled
+      evalExec (RawCode (_pcCode code)) Transactional (_srDbEnv runtime) (_srSPVSupport runtime) ge mempty SimpleNamespacePolicy
         def msgData def parsedCode >>= \case
         Left pe ->
           pure $ pactErrorToCommandResult requestKey pe (Gas 0)
@@ -323,7 +324,8 @@ computeResultAndUpdateState runtime requestKey cmd =
             , _cRollback = _cmRollback contMsg
             , _cProof = _cmProof contMsg
             }
-      evalContinuation Transactional (_srDbEnv runtime) (_srSPVSupport runtime) freeGasModel GasLogsDisabled mempty
+      ge <- mkFreeGasEnv GasLogsDisabled
+      evalContinuation Transactional (_srDbEnv runtime) (_srSPVSupport runtime) ge mempty
         SimpleNamespacePolicy def msgData def cont >>= \case
           Left pe ->
             pure $ pactErrorToCommandResult requestKey pe (Gas 0)

pact/Pact/Core/Evaluate.hs

@@ -73,17 +73,25 @@ import qualified Data.Text as T
 
 import qualified Data.ByteString as BS
 import qualified Pact.Core.Serialise.LegacyPact as Legacy
-import Pact.Core.Serialise
 import Pact.Core.Pretty
 import Pact.Core.IR.Term
 
-_decodeModule :: FilePath -> IO ()
-_decodeModule fp = do
+-- | Function for debugging legacy serialized module data.
+--   feel free to delete after mainnet launch
+--   It's only useful for debugging some code paths in the legacy serialization.
+_decodeDbgModule :: FilePath -> IO ()
+_decodeDbgModule fp = do
   x <- BS.readFile fp
   let y = either error id $ Legacy.decodeModuleData' x
-  let (ModuleData m _) = y --view document y
-  putStrLn $ "LENGTH OF DEFS: " <> show (length (_mDefs m))
+  let m = unsafeAsModuleData y
+  let (ModuleCode code) = _mCode m
+  putStrLn $ T.unpack code
+  putStrLn "\n\nPRETTYIED REPR\n\n"
   putStrLn $ show $ pretty m
+  where
+  unsafeAsModuleData = \case
+    ModuleData m _ -> m
+    _ -> error "not a module data"
 
 type Eval = EvalM ExecRuntime CoreBuiltin Info
 
@@ -92,11 +100,6 @@ type EvalBuiltinEnv = CEK.CoreBuiltinEnv Info
 type PactTxResult a =
   (Either (PactError Info) (a, [TxLog ByteString], Maybe TxId), EvalState CoreBuiltin Info)
 
-data EnableGasLogs
-  = GasLogsEnabled
-  | GasLogsDisabled
-  deriving (Eq, Show, Ord)
-
 evalInterpreter :: Interpreter ExecRuntime CoreBuiltin Info
 evalInterpreter =
   Interpreter runGuard runTerm resume evalWithCap
@@ -167,21 +170,13 @@ setupEvalEnv
   -> ExecutionMode -- <- we have this
   -> MsgData -- <- create at type for this
   -> Maybe Cont
-  -> GasModel CoreBuiltin
-  -> EnableGasLogs
+  -> GasEnv CoreBuiltin a
   -> NamespacePolicy
   -> SPVSupport
   -> PublicData
   -> S.Set ExecutionFlag
   -> IO (EvalEnv CoreBuiltin a)
-setupEvalEnv pdb mode msgData mCont gasModel' gasLogsEnabled np spv pd efs = do
-  gasRef <- newIORef mempty
-  gasLogs <- if gasLogsEnabled == GasLogsEnabled then Just <$> newIORef mempty else pure Nothing
-  let gasEnv = GasEnv
-        { _geGasRef = gasRef
-        , _geGasLog = gasLogs
-        , _geGasModel = gasModel'
-        }
+setupEvalEnv pdb mode msgData mCont gasEnv np spv pd efs = do
   pure $ EvalEnv
     { _eeMsgSigs = mkMsgSigs $ mdSigners msgData
     , _eeMsgVerifiers = mkMsgVerifiers $ mdVerifiers msgData
@@ -210,41 +205,38 @@ setupEvalEnv pdb mode msgData mCont gasModel' gasLogsEnabled np spv pd efs = do
 
 evalExec
   :: RawCode -> ExecutionMode -> PactDb CoreBuiltin Info
-  -> SPVSupport -> GasModel CoreBuiltin
-  -> EnableGasLogs
+  -> SPVSupport -> GasEnv CoreBuiltin Info
   -> Set ExecutionFlag -> NamespacePolicy
   -> PublicData -> MsgData
   -> CapState QualifiedName PactValue
   -> [Lisp.TopLevel SpanInfo] -> IO (Either (PactError Info) EvalResult)
-evalExec code execMode db spv gasModel gle flags nsp publicData msgData capState terms = do
-  evalEnv <- setupEvalEnv db execMode msgData Nothing gasModel gle nsp spv publicData flags
+evalExec code execMode db spv gasModel flags nsp publicData msgData capState terms = do
+  evalEnv <- setupEvalEnv db execMode msgData Nothing gasModel nsp spv publicData flags
   let evalState = def & esCaps .~ capState
   interpret code evalEnv evalState (Right terms)
 
 evalExecTerm
   :: ExecutionMode
   -> PactDb CoreBuiltin Info
-  -> SPVSupport -> GasModel CoreBuiltin
-  -> EnableGasLogs
+  -> SPVSupport -> GasEnv CoreBuiltin Info
   -> Set ExecutionFlag -> NamespacePolicy
   -> PublicData -> MsgData
   -> CapState QualifiedName PactValue
   -> Lisp.Expr SpanInfo -> IO (Either (PactError Info) EvalResult)
-evalExecTerm execMode db spv gasModel gle flags nsp publicData msgData capState term = do
-  evalEnv <- setupEvalEnv db execMode msgData Nothing gasModel gle nsp spv publicData flags
+evalExecTerm execMode db spv gasModel flags nsp publicData msgData capState term = do
+  evalEnv <- setupEvalEnv db execMode msgData Nothing gasModel nsp spv publicData flags
   let evalState = def & esCaps .~ capState
   interpret (RawCode mempty) evalEnv evalState (Right [Lisp.TLTerm term])
 
 evalContinuation
   :: ExecutionMode -> PactDb CoreBuiltin Info -> SPVSupport
-  -> GasModel CoreBuiltin
-  -> EnableGasLogs
+  -> GasEnv CoreBuiltin Info
   -> Set ExecutionFlag -> NamespacePolicy
   -> PublicData -> MsgData
   -> CapState QualifiedName PactValue
   -> Cont -> IO (Either (PactError Info) EvalResult)
-evalContinuation execMode db spv gasModel gle flags nsp publicData msgData capState cont = do
-  evalEnv <- setupEvalEnv db execMode msgData (Just cont) gasModel gle nsp spv publicData flags
+evalContinuation execMode db spv gasModel flags nsp publicData msgData capState cont = do
+  evalEnv <- setupEvalEnv db execMode msgData (Just cont) gasModel nsp spv publicData flags
   let evalState = def & esCaps .~ capState
   case _cProof cont of
     Nothing ->
@@ -265,14 +257,13 @@ evalContinuation execMode db spv gasModel gle flags nsp publicData msgData capSt
 evalGasPayerCap
   :: CapToken QualifiedName PactValue
   -> PactDb CoreBuiltin Info -> SPVSupport
-  -> GasModel CoreBuiltin
-  -> EnableGasLogs
+  -> GasEnv CoreBuiltin Info
   -> Set ExecutionFlag -> NamespacePolicy
   -> PublicData -> MsgData
   -> CapState QualifiedName PactValue
   -> Lisp.Expr Info -> IO (Either (PactError Info) EvalResult)
-evalGasPayerCap capToken db spv gasModel gle flags nsp publicData msgData capState body = do
-  evalEnv <- setupEvalEnv db Transactional msgData Nothing gasModel gle nsp spv publicData flags
+evalGasPayerCap capToken db spv gasModel flags nsp publicData msgData capState body = do
+  evalEnv <- setupEvalEnv db Transactional msgData Nothing gasModel nsp spv publicData flags
   let evalState = def & esCaps .~ capState
   interpretGasPayerTerm evalEnv evalState capToken body
 

pact/Pact/Core/Gas/TableGasModel.hs

@@ -10,6 +10,7 @@ module Pact.Core.Gas.TableGasModel
  , pointAddGas
  , scalarMulGas
  , pairingGas
+ , mkTableGasEnv
  )
  where
 
@@ -56,6 +57,9 @@ tableGasModel gl =
   , _gmGasCostConfig = tableGasCostConfig
   }
 
+mkTableGasEnv :: MilliGasLimit -> EnableGasLogs -> IO (GasEnv CoreBuiltin i)
+mkTableGasEnv mgl enabled = mkGasEnv enabled (tableGasModel mgl)
+
 replTableGasModel :: Maybe MilliGasLimit -> GasModel ReplCoreBuiltin
 replTableGasModel gl =
   GasModel

pact/Pact/Core/Gas/Types.hs

@@ -53,8 +53,11 @@ module Pact.Core.Gas.Types
   , gmNativeTable
 
   , freeGasModel
+  , mkGasEnv
+  , mkFreeGasEnv
   , GasCostConfig(..)
   , TranscendentalCost(..)
+  , EnableGasLogs(..)
   , module Pact.Core.SatWord
   ) where
 
@@ -433,6 +436,11 @@ freeGasCostConfig = GasCostConfig
   , _gcSizeOfBytePenalty = 1
   }
 
+data EnableGasLogs
+  = GasLogsEnabled
+  | GasLogsDisabled
+  deriving (Eq, Show, Ord)
+
 
 data GasModel b
   = GasModel
@@ -461,10 +469,24 @@ data GasLogEntry b i = GasLogEntry
   , _gleThisUsed :: !MilliGas
   } deriving (Show, Eq, Generic, NFData)
 
+
 data GasEnv b i
   = GasEnv
   { _geGasRef :: !(IORef MilliGas)
   , _geGasLog :: !(Maybe (IORef [GasLogEntry b i]))
   , _geGasModel :: !(GasModel b)
   } deriving (Generic, NFData)
 makeLenses ''GasEnv
+
+mkGasEnv :: EnableGasLogs -> GasModel b -> IO (GasEnv b i)
+mkGasEnv enabled model = do
+  gasRef <- newIORef mempty
+  glref <- if enabled == GasLogsEnabled then
+    Just <$> newIORef [] else
+    pure Nothing
+  pure (GasEnv gasRef glref model)
+{-# INLINE mkGasEnv #-}
+
+
+mkFreeGasEnv :: EnableGasLogs -> IO (GasEnv b i)
+mkFreeGasEnv enabled = mkGasEnv enabled freeGasModel

pact/Pact/Core/Gas/Utils.hs

@@ -5,6 +5,7 @@ module Pact.Core.Gas.Utils
   , chargeGasArgs
   , chargeFlatNativeGas
   , scalarMulMilliGas
+  , prettyGasLogs
   ) where
 
 import Control.Lens
@@ -17,6 +18,7 @@ import Pact.Core.Errors
 import Pact.Core.Gas.Types
 import Pact.Core.Gas.TableGasModel
 import Pact.Core.Environment
+import qualified Data.Text as T
 
 -- | Multiply Milligas by a scalar
 scalarMulMilliGas :: Integral a => MilliGas -> a -> MilliGas
@@ -60,3 +62,21 @@ chargeFlatNativeGas :: i -> b -> EvalM e b i ()
 chargeFlatNativeGas info nativeArg =
   chargeGasArgs info (GNative nativeArg)
 {-# INLINABLE chargeFlatNativeGas #-}
+
+-- this function assumes gas logs are in order
+prettyGasLogs :: Show b => GasModel b -> [GasArgs b] -> T.Text
+prettyGasLogs model = \case
+  [] -> "TOTAL: 0"
+  li -> let
+    (str, total) = foldl' go ([], MilliGas 0) li
+    in "TOTAL: " <> T.pack (show total) <> "\n" <> T.unlines (reverse str)
+  where
+  prettyLine (ga, used, amt) =
+    -- let used = runTableModel (_gmNativeTable model) (_gmGasCostConfig model) ga
+    T.pack (show ga) <> " used: " <> T.pack (show used) <> ", total used: " <> T.pack (show amt)
+  go (li, acc) ga =
+    let used = runTableModel (_gmNativeTable model) (_gmGasCostConfig model) ga
+        line = prettyLine (ga, used, used <> acc)
+    in (line:li, used <> acc)
+{-# INLINE prettyGasLogs #-}
+

pact/Pact/Core/Hash.hs

@@ -130,6 +130,14 @@ verifyHash h b = if hashed == h
               " but our hashing resulted in " ++ renderCompactString hashed
   where hashed = hash b
 
+-- NOTE: This instance is unsafe, but _really_ useful for debugging pasted
+-- gas logs.
+-- Uncomment and import Data.String(IsString(..)) to enable.
+-- instance IsString Hash where
+--   fromString s = case (decodeBase64UrlUnpadded $ T.encodeUtf8 (T.pack s)) of
+--     Right h -> Hash $ toShort h
+--     Left _ -> error $ "Invalid hash string: " ++ s
+
 initialHash :: Hash
 initialHash = hash mempty
 

pact/Pact/Core/IR/Eval/CEK/CoreBuiltin.hs

@@ -123,8 +123,9 @@ roundingFn :: (IsBuiltin b) => (Rational -> Integer) -> NativeFunction e b i
 roundingFn op info b cont handler _env = \case
   [VLiteral (LDecimal d)] ->
     returnCEKValue cont handler (VLiteral (LInteger (truncate (roundTo' op 0 d))))
-  [VDecimal d, VInteger prec] ->
-    returnCEKValue cont handler (VLiteral (LDecimal (roundTo' op (fromIntegral prec) d)))
+  [VDecimal d, VInteger prec] -> do
+    let roundPrec = max 0 (fromIntegral prec)
+    returnCEKValue cont handler (VLiteral (LDecimal (roundTo' op roundPrec d)))
   args -> argsError info b args
 {-# INLINE roundingFn #-}
 

pact/Pact/Core/IR/Eval/CEK/Evaluator.hs

@@ -1328,12 +1328,10 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args cont handler
     NullaryClosure -> do
       let varEnv = mempty
       evalWithStackFrame cloi cont handler (set ceLocal varEnv env) mty (StackFrame fqn [] SFDefun cloi) term
-  | argLen > arity = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY AL: " <> show fqn
+  | argLen > arity =
     throwExecutionError cloi ClosureAppliedToTooManyArgs
   | otherwise = case ca of
-    NullaryClosure -> do
-      -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY NULLARY: " <> show fqn
+    NullaryClosure ->
       throwExecutionError cloi ClosureAppliedToTooManyArgs
     ArgClosure cloargs
       | null args ->
@@ -1353,8 +1351,7 @@ applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args cont handler
         -- Todo: fix partial SF args
         pclo = PartialClosure (Just (StackFrame fqn [] SFDefun cloi)) (ty :| tys) (length tys + 1) term mty env' cloi
     returnCEKValue cont handler (VPartialClosure pclo)
-  apply' _ [] _ = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY IMPOSSIBLE1: " <> show fqn
+  apply' _ [] _ =
     throwExecutionError cloi ClosureAppliedToTooManyArgs
 
 applyLam (LC (LamClosure ca arity term mty env cloi)) args cont handler
@@ -1370,18 +1367,15 @@ applyLam (LC (LamClosure ca arity term mty env cloi)) args cont handler
       let cont' = EnforcePactValueC cloi cont
       evalCEK cont' handler env term
   | argLen > arity = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:LAM 42069: " <> show (() <$ ca)
     throwExecutionError cloi ClosureAppliedToTooManyArgs
   | otherwise = case ca of
       NullaryClosure -> do
-        -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:LAMNULLARY 42069: " <> show (() <$ ca)
         throwExecutionError cloi ClosureAppliedToTooManyArgs
       ArgClosure cloargs -> do
         chargeGasArgs cloi (GAApplyLam Nothing argLen)
         apply' (view ceLocal env) (NE.toList cloargs) args
   where
   argLen = length args
-  -- Todo: runtime TC here
   apply' e (Arg _ ty _:tys) (x:xs) = do
     x' <- enforcePactValue cloi x
     maybeTCType cloi ty x'
@@ -1392,7 +1386,6 @@ applyLam (LC (LamClosure ca arity term mty env cloi)) args cont handler
     returnCEKValue cont handler
     (VPartialClosure (PartialClosure Nothing (ty :| tys) (length tys + 1) term mty (set ceLocal e env) cloi))
   apply' _ [] _ = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:LAM 42069:IMPOSSIBLE2 " <> show (() <$ ca)
     throwExecutionError cloi ClosureAppliedToTooManyArgs
 
 applyLam (PC (PartialClosure li argtys _ term mty env cloi)) args cont handler = do
@@ -1414,15 +1407,13 @@ applyLam (PC (PartialClosure li argtys _ term mty env cloi)) args cont handler =
     let pclo = PartialClosure li (ty :| tys) (length tys + 1) term mty (set ceLocal e env) cloi
     returnCEKValue cont handler (VPartialClosure pclo)
   apply' _ [] _ = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:IMPOSSIBLE3 " <> show ((fmap.fmap) (const ()) argtys)
     throwExecutionError cloi ClosureAppliedToTooManyArgs
 
 applyLam nclo@(N (NativeFn b env fn arity i)) args cont handler
   | arity == argLen = do
     chargeFlatNativeGas i b
     fn i b cont handler env args
   | argLen > arity = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:NATIVE42069: " <> show args
     throwExecutionError i ClosureAppliedToTooManyArgs
   | null args = returnCEKValue cont handler (VClosure nclo)
   | otherwise =
@@ -1438,7 +1429,6 @@ applyLam (PN (PartialNativeFn b env fn arity pArgs i)) args cont handler
     chargeFlatNativeGas i b
     fn i b cont handler env (reverse pArgs ++ args)
   | argLen > arity = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:PARTIALNATIVE42069: " <> show args
     throwExecutionError i ClosureAppliedToTooManyArgs
   | otherwise = apply' arity [] args
   where
@@ -1464,7 +1454,6 @@ applyLam (DPC (DefPactClosure fqn argtys arity env i)) args cont handler
       -- Todo: defpact has much higher overhead, we must charge a bit more gas for this
       initPact i pc cont handler env'
   | otherwise = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:DPC42069: " <> show fqn
     throwExecutionError i ClosureAppliedToTooManyArgs
   where
   argLen = length args
@@ -1475,7 +1464,6 @@ applyLam (CT (CapTokenClosure fqn argtys arity i)) args cont handler
     zipWithM_ (\arg ty -> maybeTCType i ty arg) args' argtys
     returnCEKValue cont handler (VPactValue (PCapToken (CapToken fqn args')))
   | otherwise = do
-    -- liftIO $ putStrLn $ "CLO APPLIED TOO MANY:CAPTOKEN42069: " <> show fqn
     throwExecutionError i ClosureAppliedToTooManyArgs
   where
   argLen = length args

pact/Pact/Core/IR/Eval/Direct/CoreBuiltin.hs

@@ -128,8 +128,9 @@ roundingFn :: (IsBuiltin b) => (Rational -> Integer) -> NativeFunction e b i
 roundingFn op info b _env = \case
   [VLiteral (LDecimal d)] ->
     return (VLiteral (LInteger (truncate (roundTo' op 0 d))))
-  [VDecimal d, VInteger prec] ->
-    return (VLiteral (LDecimal (roundTo' op (fromIntegral prec) d)))
+  [VDecimal d, VInteger prec] -> do
+    let roundPrec = max 0 (fromIntegral prec)
+    return (VLiteral (LDecimal (roundTo' op roundPrec d)))
   args -> argsError info b args
 {-# INLINE roundingFn #-}