Make gas units more granular

src-ghc/Pact/Bench.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Pact.Bench where
 
@@ -173,7 +174,7 @@ loadCompile f = do
 
 
 prodGasEnv :: GasEnv
-prodGasEnv = GasEnv 100000 0.01 $ tableGasModel defaultGasConfig
+prodGasEnv = GasEnv (gasLimitToMilliGasLimit 100_000) 0.01 $ tableGasModel defaultGasConfig
 
 parseCode :: Text -> IO ParsedCode
 parseCode m = ParsedCode m <$> eitherDie "parseCode" (parseExprs m)

src-ghc/Pact/GasModel/Types.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NumericUnderscores #-}
 
 
 module Pact.GasModel.Types
@@ -240,7 +241,7 @@ defEvalEnv db = do
   setupEvalEnv db entity Transactional (initMsgData pactInitialHash) (versionedNativesRefStore noPact44EC)
     prodGasModel permissiveNamespacePolicy noSPVSupport def noPact44EC
   where entity = Just $ EntityName "entity"
-        prodGasModel = GasEnv 10000000 0.01 $ tableGasModel defaultGasConfig
+        prodGasModel = GasEnv (gasLimitToMilliGasLimit 10_000_000) 0.01 $ tableGasModel defaultGasConfig
         noPact44EC = mkExecutionConfig [FlagDisablePact44]
 
 -- MockDb

src-ghc/Pact/Interpreter.hs

@@ -187,7 +187,7 @@ setupEvalEnv
   -> ExecutionConfig
   -> IO (EvalEnv e)
 setupEvalEnv dbEnv ent mode msgData refStore gasEnv np spv pd ec = do
-  gasRef <- newIORef 0
+  gasRef <- newIORef mempty
   warnRef <- newIORef mempty
   pure EvalEnv {
     _eeRefStore = refStore
@@ -298,16 +298,23 @@ interpret :: Interpreter e -> EvalEnv e -> EvalInput -> IO EvalResult
 interpret runner evalEnv terms = do
   ((rs,logs,txid),state) <-
     runEval def evalEnv $ evalTerms runner terms
-  gas <- readIORef (_eeGas evalEnv)
+  milliGas <- readIORef (_eeGas evalEnv)
   warnings <- readIORef (_eeWarnings evalEnv)
-  let gasLogs = _evalLogGas state
+  let pact48Disabled = views (eeExecutionConfig . ecFlags) (S.member FlagDisablePact48) evalEnv
+      gasLogs = _evalLogGas state
       pactExec = _evalPactExec state
       modules = _rsLoadedModules $ _evalRefs state
+      gasUsed = if pact48Disabled then milliGasToGas milliGas else gasRem milliGas
   -- output uses lenient conversion
   return $! EvalResult
     terms
     (map (elideModRefInfo . toPactValueLenient) rs)
-    logs pactExec gas modules txid gasLogs (_evalEvents state) warnings
+    logs pactExec gasUsed modules txid gasLogs (_evalEvents state) warnings
+  where
+    -- Round up by 1 if the `MilliGas` amount is in any way fractional.
+    gasRem (MilliGas milliGas) =
+      let (d, r) = milliGas `quotRem` millisPerGas
+      in Gas (if r == 0 then d else d+1)
 
 evalTerms :: Interpreter e -> EvalInput -> Eval e EvalOutput
 evalTerms interp input = withRollback (start (interpreter interp runInput) >>= end)

src-ghc/Pact/Server/PactService.hs

@@ -99,7 +99,8 @@ applyCmd logger conf dbv gasModel bh _ pbh spv exConfig exMode _ (ProcSucc cmd)
   blocktime <-  (((*) 1000000) <$> systemSeconds <$> getSystemTime)
 
   let payload = _cmdPayload cmd
-      gasEnv = GasEnv (_pmGasLimit pubMeta) (_pmGasPrice pubMeta) gasModel
+      gasLimit = gasLimitToMilliGasLimit (_pmGasLimit pubMeta)
+      gasEnv = GasEnv gasLimit (_pmGasPrice pubMeta) gasModel
       pd = PublicData pubMeta bh blocktime pbh
       pubMeta = _pMeta payload
       nid = _pNetworkId payload

src/Pact/Eval.hs

@@ -216,9 +216,9 @@ apply :: App (Term Ref) -> [Term Name] -> Eval e (Term Name)
 apply app as = reduceApp $ over appArgs (++ map liftTerm as) app
 
 topLevelCall
-  :: Info -> Text -> GasArgs -> (Gas -> Eval e (Gas, a)) -> Eval e a
+  :: Info -> Text -> GasArgs -> Eval e a -> Eval e a
 topLevelCall i name gasArgs action = call (StackFrame name i Nothing) $
-  computeGas (Left (i,name)) gasArgs >>= action
+  computeGas (Left (i,name)) gasArgs *> action
 
 -- | Acquire module admin with enforce.
 acquireModuleAdmin :: Info -> ModuleName -> Governance (Def Ref) -> Eval e CapEvalResult
@@ -233,8 +233,8 @@ enforceModuleAdmin i modGov =
       Right d@Def{..} -> case _dDefType of
         Defcap -> do
           af <- prepareUserAppArgs d [] _dInfo
-          g <- computeUserAppGas d _dInfo
-          void $ evalUserAppBody d af _dInfo g reduceBody
+          computeUserAppGas d _dInfo
+          void $ evalUserAppBody d af _dInfo reduceBody
         _ -> evalError i "enforceModuleAdmin: module governance must be defcap"
 
 
@@ -287,10 +287,10 @@ eval t =
 
 -- | Evaluate top-level term.
 eval' ::  Term Name ->  Eval e (Term Name)
-eval' (TUse u@Use{..} i) = topLevelCall i "use" (GUse _uModuleName _uModuleHash) $ \g ->
-  evalUse u >> return (g,tStr $ renderCompactText' $ "Using " <> pretty _uModuleName)
+eval' (TUse u@Use{..} i) = topLevelCall i "use" (GUse _uModuleName _uModuleHash) $
+  evalUse u >> return (tStr $ renderCompactText' $ "Using " <> pretty _uModuleName)
 eval' (TModule _tm@(MDModule m) bod i) =
-  topLevelCall i "module" (GModuleDecl (_mName m) (_mCode m)) $ \g0 -> do
+  topLevelCall i "module" (GModuleDecl (_mName m) (_mCode m)) $ do
     endAdvice <- eAdvise i (AdviceModule _tm)
     checkAllowModule i
     mNs <- use $ evalRefs . rsNamespace
@@ -325,16 +325,16 @@ eval' (TModule _tm@(MDModule m) bod i) =
           evalRefs.rsQualifiedDeps %= HM.filterWithKey (\k _ -> _fqModule k /= _mName mangledM)
 
     -- build/install module from defs
-    (g,govM) <- loadModule mangledM bod i g0
+    govM <- loadModule mangledM bod i
     szVer <- getSizeOfVersion
     _ <- computeGas (Left (i,"module")) (GPreWrite (WriteModule (_mName m) (_mCode m)) szVer)
     writeRow i Write Modules (_mName mangledM) =<< traverse (traverse toPersistDirect') govM
     endAdvice govM
-    return (g, msg $ "Loaded module " <> pretty (_mName mangledM) <> ", hash " <> pretty (_mHash mangledM))
+    return (msg $ "Loaded module " <> pretty (_mName mangledM) <> ", hash " <> pretty (_mHash mangledM))
 
 
 eval' (TModule _tm@(MDInterface m) bod i) =
-  topLevelCall i "interface" (GInterfaceDecl (_interfaceName m) (_interfaceCode m)) $ \gas -> do
+  topLevelCall i "interface" (GInterfaceDecl (_interfaceName m) (_interfaceCode m)) $ do
     endAdvice <- eAdvise i (AdviceModule _tm)
     checkAllowModule i
     mNs <- use $ evalRefs . rsNamespace
@@ -344,12 +344,12 @@ eval' (TModule _tm@(MDInterface m) bod i) =
     -- enforce no upgrades
     void $ lookupModule i (_interfaceName mangledI) >>= traverse
       (const $ evalError i $ "Existing interface found (interfaces cannot be upgraded)")
-    (g,govI) <- loadInterface mangledI bod i gas
+    govI <- loadInterface mangledI bod i
     szVer <- getSizeOfVersion
-    _ <- computeGas (Left (i, "interface")) (GPreWrite (WriteInterface (_interfaceName m) (_interfaceCode m)) szVer)
+    computeGas (Left (i, "interface")) (GPreWrite (WriteInterface (_interfaceName m) (_interfaceCode m)) szVer)
     writeRow i Write Modules (_interfaceName mangledI) =<< traverse (traverse toPersistDirect') govI
     endAdvice govI
-    return (g, msg $ "Loaded interface " <> pretty (_interfaceName mangledI))
+    return (msg $ "Loaded interface " <> pretty (_interfaceName mangledI))
 eval' t = enscope t >>= reduceEnscoped
 
 reduceEnscoped :: Term Ref -> Eval e (Term Name)
@@ -455,17 +455,16 @@ loadModule
   :: Module (Term Name)
   -> Scope n Term Name
   -> Info
-  -> Gas
-  -> Eval e (Gas,ModuleData Ref)
-loadModule m bod1 mi g0 = do
+  -> Eval e (ModuleData Ref)
+loadModule m bod1 mi = do
   mapM_ evalUse $ _mImports m
-  (g1,mdefs) <- collectNames g0 (GModuleMember $ MDModule m) bod1 $ \t -> case t of
+  mdefs <- collectNames (GModuleMember $ MDModule m) bod1 $ \case
     TDef d _ -> return $ Just $ asString (_dDefName d)
     TConst a _ _ _ _ -> return $ Just $ _aName a
     TSchema n _ _ _ _ -> return $ Just $ asString n
     tt@TTable{} -> return $ Just $ asString (_tTableName tt)
     TUse _ _ -> return Nothing
-    _ -> evalError' t "Invalid module member"
+    t -> evalError' t "Invalid module member"
   let mangled = mangleDefs (_mName m) <$> mdefs
   (evaluatedDefs, deps) <-
     ifExecutionFlagSet FlagDisablePact43
@@ -475,49 +474,46 @@ loadModule m bod1 mi g0 = do
   mGov <- resolveGovernance solvedDefs m'
   let md = ModuleData mGov solvedDefs deps
   installModule True md Nothing
-  return (g1,md)
+  return md
 
 loadInterface
   :: Interface
   -> Scope n Term Name
   -> Info
-  -> Gas
-  -> Eval e (Gas,ModuleData Ref)
-loadInterface i body info gas0 = do
+  -> Eval e (ModuleData Ref)
+loadInterface i body info = do
   mapM_ evalUse $ _interfaceImports i
-  (gas1,idefs) <- collectNames gas0 (GModuleMember $ MDInterface i) body $ \t -> case t of
+  idefs <- collectNames (GModuleMember $ MDInterface i) body $ \case
     TDef d _ -> return $ Just $ asString (_dDefName d)
     TConst a _ _ _ _ -> return $ Just $ _aName a
     TSchema n _ _ _ _ -> return $ Just $ asString n
     TUse _ _ -> return Nothing
-    _ -> evalError' t "Invalid interface member"
+    t -> evalError' t "Invalid interface member"
   evaluatedDefs <- evaluateDefs info (MDInterface i) $
       mangleDefs (_interfaceName i) <$> idefs
   let md = ModuleData (MDInterface i) evaluatedDefs mempty
   installModule True md Nothing
-  return (gas1,md)
+  return md
 
 -- | Retrieve map of definition names to their corresponding terms
 -- and compute their gas value
 --
 collectNames
-  :: Gas
-    -- ^ initial gas value
-  -> GasArgs
+  :: GasArgs
     -- ^ gas args (should be GModuleMember)
   -> Scope n Term Name
     -- ^ module body
   -> (Term Name -> Eval e (Maybe Text))
     -- ^ function extracting definition names
-  -> Eval e (Gas, HM.HashMap Text (Term Name))
-collectNames g0 args body k = case instantiate' body of
+  -> Eval e (HM.HashMap Text (Term Name))
+collectNames args body k = case instantiate' body of
     TList bd _ _ -> do
       ns <- view $ eeRefStore . rsNatives
-      foldM (go ns) (g0, mempty) bd
+      foldM (go ns) mempty bd
     t -> evalError' t $ "malformed declaration"
   where
-    go ns (g,ds) t = k t >>= \dnm -> case dnm of
-      Nothing -> return (g, ds)
+    go ns ds t = k t >>= \dnm -> case dnm of
+      Nothing -> return ds
       Just dn -> do
         -- disallow native overlap
         when (isJust $ HM.lookup dn ns) $
@@ -526,8 +522,8 @@ collectNames g0 args body k = case instantiate' body of
         when (isJust $ HM.lookup dn ds) $
           evalError' t $ "definition name conflict: " <> pretty dn
 
-        g' <- computeGas (Left (_tInfo t,dn)) args
-        return (g + g',HM.insert dn t ds)
+        computeGas (Left (_tInfo t,dn)) args
+        return (HM.insert dn t ds)
 
 
 resolveGovernance
@@ -1131,7 +1127,7 @@ resolveArg ai as i = case as ^? ix i of
   Nothing -> appError ai $ "Missing argument value at index " <> pretty i
   Just i' -> i'
 
-appCall :: Pretty t => FunApp -> Info -> [Term t] -> Eval e (Gas,a) -> Eval e a
+appCall :: Pretty t => FunApp -> Info -> [Term t] -> Eval e a -> Eval e a
 appCall fa ai as = call (StackFrame (_faName fa) ai (Just (fa,map abbrev as)))
 
 enforcePactValue :: Pretty n => (Term n) -> Eval e PactValue
@@ -1153,9 +1149,9 @@ reduceApp (App (TDef d@Def{..} _) as ai) = do
       c r
       pure r
     Defpact -> do
-      g <- computeUserAppGas d ai
+      computeUserAppGas d ai
       af <- prepareUserAppArgs d as ai
-      evalUserAppBody d af ai g $ \bod' -> do
+      evalUserAppBody d af ai $ \bod' -> do
         continuation <-
           PactContinuation (QName (QualifiedName _dModule (asString _dDefName) def))
           . map elideModRefInfo
@@ -1166,7 +1162,7 @@ reduceApp (App (TLam (Lam lamName funTy body _) _) as ai) =
   functionApp (DefName lamName) funTy Nothing as body Nothing ai
 reduceApp (App (TLitString errMsg) _ i) = evalError i $ pretty errMsg
 reduceApp (App (TDynamic tref tmem ti) as ai) =
-  reduceDynamic tref tmem ti >>= \rd -> case rd of
+  reduceDynamic tref tmem ti >>= \case
     Left v -> evalError ti $ "reduceApp: expected module member for dynamic: " <> pretty v
     Right d -> reduceApp $ App (TDef d (getInfo d)) as ai
 reduceApp (App r _ ai) = evalError' ai $ "Expected def: " <> pretty r
@@ -1183,7 +1179,7 @@ functionApp
   -> Info
   -> Eval e (Term Name)
 functionApp fnName funTy mod_ as fnBody docs ai = do
-  gas <- computeGas (Left (ai, asString fnName)) (GUserApp Defun)
+  computeGas (Left (ai, asString fnName)) (GUserApp Defun)
   args <- traverse reduce as
   fty <- traverse reduce funTy
   typecheckArgs ai fnName fty args
@@ -1192,7 +1188,7 @@ functionApp fnName funTy mod_ as fnBody docs ai = do
       fname = asString fnName
       fa = FunApp ai fname mod_ Defun (funTypes fty) docs
 
-  returnVal <- guardRecursion fname mod_ $ appCall fa ai args' $ fmap (gas,) $ reduceBody body
+  returnVal <- guardRecursion fname mod_ $ appCall fa ai args' $ reduceBody body
 
   unlessExecutionFlagSet FlagDisableRuntimeReturnTypeChecking $
     typecheckTerm ai (_ftReturn fty) returnVal
@@ -1231,7 +1227,7 @@ reduceDynamic tref tmem i = do
 
 
 -- | precompute "UserApp" cost
-computeUserAppGas :: Def Ref -> Info -> Eval e Gas
+computeUserAppGas :: Def Ref -> Info -> Eval e ()
 computeUserAppGas Def{..} ai = computeGas (Left (ai, asString _dDefName)) (GUserApp _dDefType)
 
 -- | prepare reduced args and funtype, and typecheck
@@ -1253,11 +1249,11 @@ guardRecursion fname m act  =
     sfn == fname && (_faModule . fst =<< app) == m
 
 -- | Instantiate args in body and evaluate using supplied action.
-evalUserAppBody :: Def Ref -> ([Term Name], FunType (Term Name)) -> Info -> Gas
+evalUserAppBody :: Def Ref -> ([Term Name], FunType (Term Name)) -> Info
                 -> (Term Ref -> Eval e (Term Name)) -> Eval e (Term Name)
-evalUserAppBody _d@Def{..} (as',ft') ai g run = guardRecursion fname (Just _dModule) $ do
+evalUserAppBody _d@Def{..} (as',ft') ai run = guardRecursion fname (Just _dModule) $ do
   c <- eAdvise ai (AdviceUser _d)
-  !r <- appCall fa ai as' $ fmap (g,) $ run bod'
+  !r <- appCall fa ai as' $ run bod'
   c r
   pure r
   where
@@ -1563,7 +1559,7 @@ resumeNestedPactExec i def' req ctx = do
 
   let args = map (liftTerm . fromPactValue) (_pcArgs (_npeContinuation ctx))
 
-  g <- computeUserAppGas def' i
+  computeUserAppGas def' i
   af <- prepareUserAppArgs def' args i
 
   -- if resume is in step, use that, otherwise get from exec state
@@ -1573,7 +1569,7 @@ resumeNestedPactExec i def' req ctx = do
 
   -- run local environment with yield from pact exec
   local (set eePactStep (Just $ set psResume resume req)) $
-    evalUserAppBody def' af i g $ \bod ->
+    evalUserAppBody def' af i $ \bod ->
       applyNestedPact i (_npeContinuation ctx) bod req
 
 
@@ -1607,7 +1603,7 @@ resumePactExec i req ctx = do
 
   let args = map (liftTerm . fromPactValue) (_pcArgs (_peContinuation ctx))
 
-  g <- computeUserAppGas def' i
+  computeUserAppGas def' i
   af <- prepareUserAppArgs def' args i
 
   -- if resume is in step, use that, otherwise get from exec state
@@ -1617,7 +1613,7 @@ resumePactExec i req ctx = do
 
   -- run local environment with yield from pact exec
   local (set eePactStep (Just $ set psResume resume req)) $
-    evalUserAppBody def' af i g $ \bod ->
+    evalUserAppBody def' af i $ \bod ->
       applyPact i (_peContinuation ctx) bod req (_peNested ctx)