From 018cb77e70a00a5d075566db9c3f4424ec4a12b8 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Tue, 6 Aug 2024 16:57:52 -0400 Subject: [PATCH] Remove smallstep CEK --- gasmodel/Main.hs | 2 - gasmodel/Pact/Core/GasModel/ContractBench.hs | 2 +- gasmodel/Pact/Core/GasModel/InterpreterGas.hs | 1339 ----------------- gasmodel/Pact/Core/GasModel/Utils.hs | 121 +- pact-lsp/Pact/Core/LanguageServer.hs | 2 +- pact-tests/Pact/Core/Test/GasGolden.hs | 1 - pact-tests/Pact/Core/Test/ReplTests.hs | 2 - pact-tng.cabal | 1 - pact/Pact/Core/Evaluate.hs | 4 +- pact/Pact/Core/IR/Eval/CEK.hs | 380 +++-- pact/Pact/Core/IR/Eval/CEK/Types.hs | 261 ++-- pact/Pact/Core/IR/Eval/CEK/Utils.hs | 18 +- pact/Pact/Core/IR/Eval/CoreBuiltin.hs | 316 ++-- pact/Pact/Core/Repl/Compile.hs | 24 +- pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs | 76 +- profile-tx/ProfileTx.hs | 2 +- 16 files changed, 507 insertions(+), 2044 deletions(-) delete mode 100644 gasmodel/Pact/Core/GasModel/InterpreterGas.hs diff --git a/gasmodel/Main.hs b/gasmodel/Main.hs index ea1ce4cfa..e60ff3a89 100644 --- a/gasmodel/Main.hs +++ b/gasmodel/Main.hs @@ -5,7 +5,6 @@ module Main where import qualified Criterion.Main as C -import Pact.Core.GasModel.InterpreterGas as InterpreterGas import Pact.Core.GasModel.BuiltinsGas as BuiltinsGas import Pact.Core.GasModel.ContractBench as ContractBench import Pact.Core.GasModel.Serialization as Serialization @@ -14,7 +13,6 @@ main :: IO () main = do C.defaultMain [ ContractBench.allBenchmarks - , InterpreterGas.benchmarks , BuiltinsGas.benchmarks , Serialization.benchmarks ] diff --git a/gasmodel/Pact/Core/GasModel/ContractBench.hs b/gasmodel/Pact/Core/GasModel/ContractBench.hs index a11e28d61..2d3bc67e3 100644 --- a/gasmodel/Pact/Core/GasModel/ContractBench.hs +++ b/gasmodel/Pact/Core/GasModel/ContractBench.hs @@ -73,7 +73,7 @@ interpretBigStep = where runTerm purity term = CEK.eval purity eEnv term runGuard info g = CEK.interpretGuard info eEnv g - eEnv = CEK.coreBuiltinEnv @ExecRuntime @CEK.CEKBigStep + eEnv = CEK.coreBuiltinEnv @ExecRuntime interpretDirect :: Interpreter ExecRuntime CoreBuiltin SpanInfo interpretDirect = diff --git a/gasmodel/Pact/Core/GasModel/InterpreterGas.hs b/gasmodel/Pact/Core/GasModel/InterpreterGas.hs deleted file mode 100644 index 620556e4e..000000000 --- a/gasmodel/Pact/Core/GasModel/InterpreterGas.hs +++ /dev/null @@ -1,1339 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} - -module Pact.Core.GasModel.InterpreterGas(benchmarks) where - -import Control.Lens -import Control.Monad.IO.Class -import Data.Default -import qualified Data.RAList as RA -import qualified Data.List.NonEmpty as NE -import qualified Criterion as C -import qualified Data.Text as T -import qualified Data.Set as S -import qualified Data.Map.Strict as M - -import Pact.Core.Builtin -import Pact.Core.Environment -import Pact.Core.Errors -import Pact.Core.Names -import Pact.Core.Gas -import Pact.Core.Literal -import Pact.Core.Type -import Pact.Core.Capabilities -import Pact.Core.IR.Eval.Runtime -import Pact.Core.PactValue -import Pact.Core.IR.Term -import Pact.Core.Persistence -import Pact.Core.Hash -import Pact.Core.Info (SpanInfo) -import Pact.Core.Persistence.SQLite -import Pact.Core.Serialise (serialisePact_raw_spaninfo) -import Pact.Core.IR.Eval.CEK.Types -import qualified Pact.Core.IR.Eval.CEK as Eval - -import Pact.Core.GasModel.Utils - - -runEvalDropState - :: EvalEnv b i - -> EvalState b i - -> EvalM ExecRuntime b i a - -> IO (Either (PactError i) a) -runEvalDropState ee es = fmap fst . runEvalM (ExecEnv ee) es - -benchmarks :: C.Benchmark -benchmarks = C.envWithCleanup mkPactDb cleanupPactDb $ \ ~(pdb, _, _) -> do - C.bgroup "TermEvalGasCEK" [staticExecutionBenchmarks pdb, termGas pdb, interpReturnGas pdb] - where - mkPactDb = do - (pdb, db, cache) <- unsafeCreateSqlitePactDb serialisePact_raw_spaninfo ":memory:" - ignoreGas def $ prepopulateDb pdb - _ <- _pdbBeginTx pdb Transactional - pure (pdb, NoNf db, NoNf cache) - - cleanupPactDb (_, NoNf db, NoNf cache) = - unsafeCloseSqlitePactDb db cache - -gasVarBound :: Int -> EvalEnv CoreBuiltin SpanInfo -> EvalState CoreBuiltin SpanInfo -> C.Benchmark -gasVarBound n ee es = do - let term = Var (Name "_" (NBound (fromIntegral (n-1)))) def - let pdb = _eePactDb ee - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal = RA.fromList (replicate n VUnit) - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins= benchmarkEnv } - let title = "Var: " <> show n <> "th var case" - C.env (pure (term, es, ee, env)) $ \ ~(term', es', ee', env') -> do - C.bench title $ C.nfAppIO (runEvalDropState ee' es' . Eval.evaluateTermSmallStep Mt CEKNoHandler env') term' - -varGas :: CoreDb -> C.Benchmark -varGas pdb = - C.env mkEnv $ \ ~(ee, es) -> - C.bgroup "Variables: bound" $ (\i -> gasVarBound i ee es) <$> [10, 50, 100, 150, 200, 250, 300, 400, 450] - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - pure (ee, es) - -simpleTermGas :: CoreTerm SpanInfo -> String -> CoreDb -> C.Benchmark -simpleTermGas term title pdb = - C.env mkEnv $ \ ~(term', es', ee', env') -> do - C.bench title $ C.nfAppIO (runEvalDropState ee' es' . Eval.evaluateTermSmallStep Mt CEKNoHandler env') term' - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - pure (term, es, ee, env) - --- Constant gas simply wraps the result in VLiteral -constantGas :: CoreDb -> C.Benchmark -constantGas = simpleTermGas unitConst "Constant Node" - --- App simply enriches the continuation and continues eval -appGas :: CoreDb -> C.Benchmark -appGas = simpleTermGas (App unitConst [] def) "App Node" - -nullaryGas :: CoreDb -> C.Benchmark -nullaryGas = simpleTermGas (Nullary unitConst def) "Nullary Node" - -letGas :: CoreDb -> C.Benchmark -letGas = - let letBind = Let (Arg "_" Nothing def) unitConst unitConst def - in simpleTermGas letBind "Let Node" - -constantExample :: CoreTerm SpanInfo -> CEKValue ExecRuntime CEKSmallStep CoreBuiltin SpanInfo -constantExample (Constant LUnit _) = VPactValue (PLiteral LUnit) -constantExample _ = error "boom" - -constantGasEquiv :: C.Benchmark -constantGasEquiv = do - let term = (Constant LUnit def) :: CoreTerm SpanInfo - C.env (pure term) $ \ ~(c) -> - C.bench "constant example: no monadic overhead" $ C.nf constantExample c - --- Simple case for evaluating to normal form for (+ 1 2) -plusOneTwo :: CoreDb -> C.Benchmark -plusOneTwo pdb = do - C.env mkEnv $ \ ~(term', es', ee', env') -> do - C.bench "(+ 1 2)" $ C.nfAppIO (runEvalDropState ee' es' . Eval.evalNormalForm env') term' - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkBigStepEnv } - let term = App (Builtin CoreAdd def) [Constant (LInteger 1) def, Constant (LInteger 2) def] def - pure (term, es, ee, env) - -constExpr :: CoreDb -> C.Benchmark -constExpr pdb = do - C.env mkEnv $ \ ~(term', es', ee', env') -> do - C.bench "constExpr" $ C.nfAppIO (runEvalDropState ee' es' . Eval.evalNormalForm env') term' - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkBigStepEnv } - let lamTerm = Lam (NE.fromList [Arg "_" Nothing def, Arg "_" Nothing def]) (Var (Name "boop" (NBound 1)) def) def - let term = App lamTerm [Constant (LInteger 1) def, Constant (LInteger 2) def] def - pure (term, es, ee, env) - -constExpr2 :: CoreDb -> C.Benchmark -constExpr2 pdb = do - C.env mkEnv $ \ ~(term', es', ee', env') -> do - C.bench "(map (+ 1) (enumerate 0 999999))" $ C.nfAppIO (runEvalDropState ee' es' . Eval.evalNormalForm env') term' - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkBigStepEnv } - let lamTerm = App (Builtin CoreAdd def) [intConst 1] def - enumerateTerm = App (Builtin CoreEnumerate def) [intConst 0, intConst 999999] def - let term = App (Builtin CoreMap def) [lamTerm, enumerateTerm] def - pure (term, es, ee, env) - --- Gas for a lambda with N arguments --- gasLamNArgs :: Int -> EvalEnv CoreBuiltin SpanInfo -> EvalState CoreBuiltin SpanInfo -> C.Benchmark -gasLamNArgs :: Int -> CoreDb -> C.Benchmark -gasLamNArgs n pdb = - C.env mkEnv $ \ ~(term', es', ee', env') -> - C.bench title $ C.nfAppIO (runEvalDropState ee' es' . Eval.evaluateTermSmallStep Mt CEKNoHandler env') term' - where - title = "Lam: " <> show n <> " args case" - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - mkArg i = Arg ("Arg#" <> T.pack (show i)) Nothing def - args = mkArg <$> [1..n] - term = Lam (NE.fromList args) (Constant LUnit def) def - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal = mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins= benchmarkEnv } - - pure (term, es, ee, env) - -lamGas :: CoreDb -> C.Benchmark -lamGas pdb = - C.bgroup "Lambda Node" $ [ gasLamNArgs i pdb | i <- [1..25]] - -seqGas :: CoreDb -> C.Benchmark -seqGas = simpleTermGas (Sequence unitConst unitConst def) "Seq Node" - -condCAndGas :: CoreDb -> C.Benchmark -condCAndGas = simpleTermGas (Conditional (CAnd unitConst unitConst) def) "Conditional CAnd Node" - -condCOrGas :: CoreDb -> C.Benchmark -condCOrGas = simpleTermGas (Conditional (COr unitConst unitConst) def) "Conditional If Node" - -condCIfGas :: CoreDb -> C.Benchmark -condCIfGas = simpleTermGas (Conditional (CIf unitConst unitConst unitConst) def) "Conditional CIf Node" - -condCEnforceOneGas :: CoreDb -> C.Benchmark -condCEnforceOneGas pdb = - C.bgroup "CondCEnforceOne" $ - [ simpleTermGas (Conditional (CEnforceOne unitConst []) def) "Conditional CEnforceOne []" pdb - , simpleTermGas (Conditional (CEnforceOne unitConst [unitConst]) def) "Conditional CEnforceOne [x]" pdb - , simpleTermGas (Conditional (CEnforceOne unitConst [unitConst, unitConst]) def) "Conditional CEnforceOne [x,x]" pdb ] - -condCEnforceGas :: CoreDb -> C.Benchmark -condCEnforceGas = simpleTermGas (Conditional (CEnforce unitConst unitConst) def) "Conditional CIf Node" - -builtinNodeGas :: CoreDb -> C.Benchmark -builtinNodeGas = simpleTermGas (Builtin CoreAt def) "Builtin node" - -listLitGas :: CoreDb -> C.Benchmark -listLitGas pdb = - C.bgroup "ListLit" $ - [ simpleTermGas (ListLit [] def) "[]" pdb - , simpleTermGas (ListLit [unitConst] def) "[x]" pdb - , simpleTermGas (ListLit [unitConst, unitConst] def) "[x,x]" pdb ] - -tryGas :: CoreDb -> C.Benchmark -tryGas = - simpleTermGas (Try unitConst unitConst def) "Try Node" - -objectLitGas :: CoreDb -> C.Benchmark -objectLitGas pdb = - C.bgroup "ObjectLit" $ - [ simpleTermGas (ObjectLit [] def) "{}" pdb - , simpleTermGas (ObjectLit [(Field "x", unitConst)] def) "{x:()}" pdb - , simpleTermGas (ObjectLit [(Field "x", unitConst), (Field "y", unitConst)] def) "{x:(), y:()}" pdb ] - -termGas :: CoreDb -> C.Benchmark -termGas pdb = C.bgroup "term reduction benchmarks" (benchmarkNodeType pdb <$> [minBound .. maxBound]) - -staticExecutionBenchmarks :: CoreDb -> C.Benchmark -staticExecutionBenchmarks pdb = - C.bgroup "Simple reduction benchmarks" - [ plusOneTwo pdb - , constExpr pdb - , constExpr2 pdb - , constantGasEquiv] - -interpReturnGas :: CoreDb -> C.Benchmark -interpReturnGas pdb = - C.bgroup "CEKH continuation control flow benches" $ gasContType pdb <$> [minBound .. maxBound] - -withCapFormGas :: CoreDb -> C.Benchmark -withCapFormGas = - simpleTermGas (CapabilityForm (WithCapability unitConst unitConst) def) "Capability node" - - -createUserGuardGasNArgs :: Int -> CoreDb -> C.Benchmark -createUserGuardGasNArgs nArgs pdb = - C.env mkEnv $ \ ~(term', es', ee', env') -> do - C.bench title $ C.nfAppIO (runEvalDropState ee' es' . Eval.evaluateTermSmallStep Mt CEKNoHandler env') term' - where - title = "Create User Guard, " <> show nArgs <> " args" - mkEnv = do - let args = [ Arg ("_foo" <> T.pack (show i)) Nothing def | i <- [2..nArgs] ] - ee <- liftIO $ defaultGasEvalEnv pdb - let mn = ModuleName "foomodule" Nothing - mh = ModuleHash (pactHash "foo") - fqn = FullyQualifiedName mn "foo" mh - dfun = Defun (Arg "foo" Nothing def) args unitConst def - es = over (esLoaded . loAllLoaded) (M.insert fqn (Dfun dfun)) def - name = Name "foo" (NTopLevel mn mh) - term = CapabilityForm (CreateUserGuard name (replicate nArgs unitConst)) def - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - pure (term, es, ee, env) - -createUserGuardGas :: CoreDb -> C.Benchmark -createUserGuardGas pdb = - C.bgroup "Create user guard node" [ createUserGuardGasNArgs i pdb | i <- [0..5]] - - -benchmarkNodeType :: CoreDb -> NodeType -> C.Benchmark -benchmarkNodeType pdb = \case - VarNode -> varGas pdb - LamNode -> lamGas pdb - LetNode -> letGas pdb - AppNode -> appGas pdb - SeqNode -> seqGas pdb - NullaryNode -> nullaryGas pdb - -- -- conditional nodes - CondCAndNode -> condCAndGas pdb - CondCOrNode -> condCOrGas pdb - CondIfNode -> condCIfGas pdb - CondEnforceOneNode -> condCEnforceOneGas pdb - CondEnforceNode -> condCEnforceGas pdb - -- - BuiltinNode -> builtinNodeGas pdb - ConstantNode -> constantGas pdb - ListNode -> listLitGas pdb - TryNode -> tryGas pdb - ObjectLitNode -> objectLitGas pdb - CapFormWithCapNode -> withCapFormGas pdb - CapFormCreateUGNode -> createUserGuardGas pdb - - --- Gas for a lambda with N -gasMtReturnNoHandler :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasMtReturnNoHandler pdb = - C.env mkEnv $ \ ~(ee, es, frame, handler, v) -> do - C.bench "MtReturnNoHandler" $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) v - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - frame = Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - --- Gas for a lambda with N -gasMtWithHandlerValue :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasMtWithHandlerValue pdb = do - C.env mkEnv $ \ ~(ee, es, frame, handler, v) -> do - C.bench "MtWithHandlerValue" $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) v - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - frame = Mt - value = VUnit - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - handler = CEKHandler env unitConst Mt (ErrorState def [] (pure def)) CEKNoHandler - pure (ee, es, frame, handler, value) - --- Gas for a lambda with N -gasMtWithHandlerError :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasMtWithHandlerError pdb = - C.env mkEnv $ \ ~(ee, es, frame, handler, value) -> - C.bench "MtWithHandlerError" $ C.nfAppIO (runEvalDropState ee es . Eval.applyContSmallStep frame handler) value - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - frame = Mt - value = VError [] (UserEnforceError "foo") def - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - handler = CEKHandler env unitConst Mt (ErrorState def [] (pure def)) CEKNoHandler - pure (ee, es, frame, handler, value) - -gasArgsWithRemainingArgs :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasArgsWithRemainingArgs pdb = - C.env mkEnv $ \ ~(ee, es, frame, handler, value) -> - C.bench "Args Frame" $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) value - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - value = VClosure (C (unitClosureUnary env)) - frame = Args env def [unitConst] Mt - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasFnWithRemainingArgs :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasFnWithRemainingArgs pdb = - C.env mkEnv $ \ ~(ee, es, frame, handler, value) -> - C.bench "Fn Frame" $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) value - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = C (unitClosureBinary env) - frame = Fn clo env [unitConst] [VUnit] Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - - -gasLetC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasLetC pdb = - C.env mkEnv $ \ ~(ee, es, frame, handler, value) -> - C.bench "LetC frame" $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) value - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = LetC env unitConst Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasSeqC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasSeqC pdb = do - C.env mkEnv $ \ ~(ee, es, frame, handler, value) -> - C.bench title $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) value - where - title = "SeqC Frame" - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = SeqC env unitConst Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasAndC :: PactDb CoreBuiltin SpanInfo -> Bool -> C.Benchmark -gasAndC pdb b = - C.env mkEnv $ \ ~(ee, es, frame, handler, value) -> - C.bench title $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) value - where - title = "AndC gas with VBool(" <> show b <> ")" - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = CondC env def (AndC (boolConst b)) Mt - value = VBool b - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasOrC :: PactDb CoreBuiltin SpanInfo -> Bool -> C.Benchmark -gasOrC pdb b = - benchApplyContToValue mkEnv title - where - title = "OrC gas with VBool(" <> show b <> ")" - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = CondC env def (OrC (boolConst b)) Mt - value = VBool b - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasIfC :: PactDb CoreBuiltin SpanInfo -> Bool -> C.Benchmark -gasIfC pdb b = - benchApplyContToValue mkEnv title - where - title = "IfC gas with VBool(" <> show b <> ")" - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = CondC env def (IfC (boolConst b) (boolConst b)) Mt - value = VBool b - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasEnforceC :: PactDb CoreBuiltin SpanInfo -> Bool -> C.Benchmark -gasEnforceC pdb b = - benchApplyContToValue mkEnv title - where - title = "EnforceC gas with VBool(" <> show b <> ")" - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = CondC env def (EnforceC (strConst "boom")) Mt - value = VBool b - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - --- Note: FilterC applies a reverse -gasFilterCEmptyNElems :: PactDb CoreBuiltin SpanInfo -> Bool -> Int -> C.Benchmark -gasFilterCEmptyNElems pdb b i = - benchApplyContToValue mkEnv "FilterC empty acc case" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = boolClosureUnary True env - frame = CondC env def (FilterC (C clo) (PLiteral LUnit) [] (replicate i PUnit)) Mt - value = VBool b - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasAndQC :: PactDb CoreBuiltin SpanInfo -> Bool -> C.Benchmark -gasAndQC pdb b = - benchApplyContToValue mkEnv "AndQC boolean case" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = boolClosureUnary b env - frame = CondC env def (AndQC (C clo) (PLiteral LUnit)) Mt - value = VBool b - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasOrQC :: PactDb CoreBuiltin SpanInfo -> Bool -> C.Benchmark -gasOrQC pdb b = - benchApplyContToValue mkEnv "OrQC boolean case" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = boolClosureUnary b env - frame = CondC env def (OrQC (C clo) (PLiteral LUnit)) Mt - value = VBool b - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasNotQC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasNotQC pdb = - benchApplyContToValue mkEnv "NotQC boolean case" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = CondC env def (NotQC) Mt - value = VBool True - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasMapC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasMapC pdb = - benchApplyContToValue mkEnv "MapC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = unitClosureUnary env - bframe = MapC (C clo) [PUnit] [] - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasFoldC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasFoldC pdb = - benchApplyContToValue mkEnv "FoldC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = unitClosureBinary env - bframe = FoldC (C clo) [PUnit] - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasZipC :: PactDb CoreBuiltin SpanInfo ->C.Benchmark -gasZipC pdb = - benchApplyContToValue mkEnv "ZipC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = unitClosureBinary env - bframe = ZipC (C clo) ([PUnit], [PUnit]) [] - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasPreSelectC :: PactDb CoreBuiltin SpanInfo ->C.Benchmark -gasPreSelectC pdb = - benchApplyContToValue mkEnv "PreSelectC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = boolClosureUnary True env - bframe = PreSelectC gasModelTableValue (C clo) Nothing - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasPreFoldDbC :: PactDb CoreBuiltin SpanInfo ->C.Benchmark -gasPreFoldDbC pdb = - benchApplyContToValue mkEnv "PreFoldDBC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - queryClo = boolClosureUnary True env - appClo = unitClosureBinary env - bframe = PreFoldDbC gasModelTableValue (C queryClo) (C appClo) - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasSelectC :: PactDb CoreBuiltin SpanInfo ->C.Benchmark -gasSelectC pdb = - benchApplyContToValue mkEnv "SelectC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - queryClo = boolClosureUnary True env - bframe = SelectC gasModelTableValue (C queryClo) (rowDataToObjectData gmTableV1) [gmTableK2] [] Nothing - frame = BuiltinC env def bframe Mt - value = VBool True - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasFoldDbFilterC :: PactDb CoreBuiltin SpanInfo ->C.Benchmark -gasFoldDbFilterC pdb = - benchApplyContToValue mkEnv "FoldDbFilterC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - queryClo = boolClosureUnary True env - appClo = unitClosureBinary env - bframe = FoldDbFilterC gasModelTableValue (C queryClo) (C appClo) (gmTableK1,rowDataToObjectData gmTableV1) [gmTableK2] [] - frame = BuiltinC env def bframe Mt - value = VBool True - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasFoldDbMapC :: PactDb CoreBuiltin SpanInfo ->C.Benchmark -gasFoldDbMapC pdb = - benchApplyContToValue mkEnv "FoldDbMapC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - appClo = unitClosureBinary env - (RowData v) = gmTableV1 - bframe = FoldDbMapC gasModelTableValue (C appClo) [(gmTableK1, PObject v)] [] - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasReadC :: PactDb CoreBuiltin SpanInfo ->C.Benchmark -gasReadC pdb = - benchApplyContToValue mkEnv "ReadC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - bframe = ReadC gasModelTableValue gmTableK1 - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - --- Todo: further gas model work will have gasWriteC work on -gasWriteC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasWriteC pdb = - benchApplyContWithRollback mkEnv "WriteC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - bframe = WriteC gasModelTableValue Write gmTableK3 (rowDataToObjectData gmTableV3) - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasWithDefaultReadC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasWithDefaultReadC pdb = - benchApplyContToValue mkEnv "WithDefaultReadC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - clo = unitClosureUnary env - bframe = WithDefaultReadC gasModelTableValue gmTableK2 (rowDataToObjectData gmTableV2) (C clo) - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasKeysC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasKeysC pdb = - benchApplyContToValue mkEnv "KeysC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - bframe = KeysC gasModelTableValue - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasCreateTableC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCreateTableC pdb = - benchApplyContWithRollback mkEnv "SelectC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - bframe = CreateTableC gasModelTableValue2 - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasEmitEventC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasEmitEventC pdb = - benchApplyContToValue mkEnv "EmitEventC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - bframe = EmitEventC (CapToken (mkGasModelFqn gmDcapUnmanagedName) []) - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - - -gasDefineKeysetC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasDefineKeysetC pdb = - benchApplyContWithRollback mkEnv "DefineKeysetC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - bframe = DefineKeysetC gmKeysetName gmKeyset - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasDefineNamespaceC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasDefineNamespaceC pdb = - benchApplyContWithRollback mkEnv "DefineNamespaceC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - bframe = DefineNamespaceC gmNamespace - frame = BuiltinC env def bframe Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasObjC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasObjC pdb = - benchApplyContWithRollback mkEnv "ObjC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - frame = ObjC env def (Field "a") [(Field "b", intConst 1)] [] Mt - value = VUnit - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasCapInvokeCUserGuard :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapInvokeCUserGuard pdb = - benchApplyContWithRollback mkEnv "CapInvokeCUserGuard" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - cframe = CreateUserGuardC (mkGasModelFqn gmManagerDfunName) [intConst 1] [] - frame = CapInvokeC env def cframe Mt - value = VInteger 1 - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasCapInvokeCWithCapC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapInvokeCWithCapC pdb = - benchApplyContWithRollback mkEnv "CapInvokeCWithCapC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - cframe = WithCapC unitConst - frame = CapInvokeC env def cframe Mt - value = VCapToken (CapToken (mkGasModelFqn gmDcapUnmanagedName) []) - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasCapInvokeCWithCapCManaged :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapInvokeCWithCapCManaged pdb = - benchApplyContWithRollback mkEnv "CapInvokeCWithCapCManaged" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - capTokenFqn = CapToken (mkGasModelFqn gmDcapManagedName) [PInteger 1] - capTokenQn = CapToken (QualifiedName gmDcapManagedName gmModuleName) [PInteger 1] - -- Insert the managed cap into the the environment - signedEs = over eeMsgSigs (M.insert gmPublicKeyText1 (S.singleton capTokenQn)) ee - cframe = WithCapC unitConst - frame = CapInvokeC env def cframe Mt - value = VCapToken capTokenFqn - handler = CEKNoHandler - pure (signedEs, es, frame, handler, value) - -gasCapInvokeCWithCapAutoManaged :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapInvokeCWithCapAutoManaged pdb = - benchApplyContWithRollback mkEnv "CapInvokeCWithCapAutoManaged" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - capTokenFqn = CapToken (mkGasModelFqn gmDcapAutoManagedName) [] - capTokenQn = CapToken (QualifiedName gmDcapAutoManagedName gmModuleName) [] - -- Insert the managed cap into the the environment - signedEs = over eeMsgSigs (M.insert gmPublicKeyText1 (S.singleton capTokenQn)) ee - cframe = WithCapC unitConst - frame = CapInvokeC env def cframe Mt - value = VCapToken capTokenFqn - handler = CEKNoHandler - pure (signedEs, es, frame, handler, value) - -gasCapInvokeCApplyMgrFun :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapInvokeCApplyMgrFun pdb = - benchApplyContWithRollback mkEnv "ApplyMgrFunC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - capTokenFqn = CapToken (mkGasModelFqn gmDcapManagedName) [PInteger 1] - capTokenQnFiltered = CapToken (QualifiedName gmDcapManagedName gmModuleName) [] - capTokenQn = CapToken (QualifiedName gmDcapManagedName gmModuleName) [PInteger 1] - -- Insert the managed cap into the the environment - clo = intClosureBinary 1 env - mgrFunFqn = mkGasModelFqn gmManagerDfunName - mgdCap = ManagedCap {_mcOriginalCap=capTokenQn, _mcManaged=ManagedParam mgrFunFqn (PInteger 0) 0, _mcCap=capTokenQnFiltered} - signedEs = over eeMsgSigs (M.insert gmPublicKeyText1 (S.singleton capTokenQn)) ee - esWithMgd = over (esCaps . csManaged) (S.insert mgdCap) es - cframe = ApplyMgrFunC mgdCap clo (PInteger 1) (PInteger 1) - frame = CapInvokeC env def cframe Mt - value = VCapToken capTokenFqn - handler = CEKNoHandler - pure (signedEs, esWithMgd, frame, handler, value) - -gasCapInvokeCUpdMgrFun :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapInvokeCUpdMgrFun pdb = - benchApplyContWithRollback mkEnv "UpdMgrFunC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - capTokenFqn = CapToken (mkGasModelFqn gmDcapManagedName) [PInteger 1] - capTokenQnFiltered = CapToken (QualifiedName gmDcapManagedName gmModuleName) [] - capTokenQn = CapToken (QualifiedName gmDcapManagedName gmModuleName) [PInteger 1] - -- Insert the managed cap into the the environment - mgrFunFqn = mkGasModelFqn gmManagerDfunName - mgdCap = ManagedCap {_mcOriginalCap=capTokenQn, _mcManaged=ManagedParam mgrFunFqn (PInteger 0) 0, _mcCap=capTokenQnFiltered} - signedEs = over eeMsgSigs (M.insert gmPublicKeyText1 (S.singleton capTokenQn)) ee - esWithMgd = over (esCaps . csManaged) (S.insert mgdCap) es - cframe = UpdateMgrFunC mgdCap - frame = CapInvokeC env def cframe Mt - value = VCapToken capTokenFqn - handler = CEKNoHandler - pure (signedEs, esWithMgd, frame, handler, value) - -gasCapBodyC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapBodyC pdb = - benchApplyContWithRollback mkEnv "CapBodyC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - - value = VUnit - cbState = CapBodyState PopCapInvoke Nothing Nothing unitConst - frame = CapBodyC env def cbState Mt - handler = CEKNoHandler - pure (ee, es, frame, handler, value) - -gasCapPopCInvoke :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapPopCInvoke pdb = - benchApplyContWithRollback mkEnv "CapPopCInvoke " - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - capTokenQn = CapToken (QualifiedName gmDcapManagedName gmModuleName) [PInteger 1] - es' = over (esCaps . csSlots) (CapSlot capTokenQn [] :) es - cbState = CapBodyState PopCapInvoke Nothing Nothing unitConst - frame = CapBodyC env def cbState Mt - handler = CEKNoHandler - value = VUnit - pure (ee, es', frame, handler, value) - -gasCapPopCComposed :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasCapPopCComposed pdb = - benchApplyContWithRollback mkEnv "CapPopCComposed" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - ps = _eeDefPactStep ee - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins=benchmarkEnv } - capTokenQn = CapToken (QualifiedName gmDcapManagedName gmModuleName) [PInteger 1] - es' = over (esCaps . csSlots) (CapSlot capTokenQn [] :) es - cbState = CapBodyState PopCapInvoke Nothing Nothing unitConst - frame = CapBodyC env def cbState Mt - handler = CEKNoHandler - value = VUnit - pure (ee, es', frame, handler, value) - - -gasIgnoreValueC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasIgnoreValueC pdb = - benchApplyContWithRollback mkEnv "IgnoreValueC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - frame = IgnoreValueC PUnit Mt - handler = CEKNoHandler - value = VUnit - pure (ee, es, frame, handler, value) - -gasStackPopC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasStackPopC pdb = - benchApplyContWithRollback mkEnv "StackPopC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - frame = IgnoreValueC PUnit Mt - handler = CEKNoHandler - value = VUnit - pure (ee, es, frame, handler, value) - -gasModuleAdminC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasModuleAdminC pdb = - benchApplyContWithRollback mkEnv "ModuleAdminC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - frame = ModuleAdminC gmModuleName Mt - handler = CEKNoHandler - value = VUnit - pure (ee, es, frame, handler, value) - -gasEnforceBoolC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasEnforceBoolC pdb = - benchApplyContWithRollback mkEnv "EnforceBoolC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - frame = EnforceBoolC def Mt - handler = CEKNoHandler - value = VBool True - pure (ee, es, frame, handler, value) - -gasEnforcePactValueC :: PactDb CoreBuiltin SpanInfo -> C.Benchmark -gasEnforcePactValueC pdb = - benchApplyContWithRollback mkEnv "EnforcePactValueC" - where - mkEnv = do - ee <- defaultGasEvalEnv pdb - let es = defaultGasEvalState - frame = EnforcePactValueC def Mt - handler = CEKNoHandler - value = VBool True - pure (ee, es, frame, handler, value) - - -benchApplyContToValue - :: IO ApplyContToVEnv - -> String - -> C.Benchmark -benchApplyContToValue mkEnv title = - C.env mkEnv $ \ ~(ee, es, frame, handler, value) -> - C.bench title $ C.nfAppIO (runEvalDropState ee es . Eval.applyContToValueSmallStep frame handler) value - --- Note: we preform a rollback, then begin tx right after. --- This prevents us from say, inserting a value twice and changing --- the asymptotics of the benchmark. Generally, for db inserts, we want to --- benchmark the state of the world in the same way every time. -benchApplyContWithRollback - :: IO ApplyContToVEnv - -> String - -> C.Benchmark -benchApplyContWithRollback mkEnv title = - C.bench title $ C.perRunEnvWithCleanup mkEnv cleanup $ \ ~(ee, es, frame, handler, value) -> - runEvalDropState ee es $ Eval.applyContToValueSmallStep frame handler value - where - cleanup (ee, _, _, _, _) = do - let pdb = _eePactDb ee - _pdbRollbackTx pdb - _ <- _pdbBeginTx pdb Transactional - pure () - - -gasContType :: PactDb CoreBuiltin SpanInfo -> ContType -> C.Benchmark -gasContType pdb = \case - CTFn -> - -- Note: applyLam case - gasFnWithRemainingArgs pdb - CTArgs -> - -- Note: applyLam case is not handled - gasArgsWithRemainingArgs pdb - CTLetC -> - gasLetC pdb - CTSeqC -> - gasSeqC pdb - CTListC -> C.bgroup "list benchmarks" [] -- TODO - -- Conditionals - CTAndC -> - C.bgroup "AndC Cases" $ (gasAndC pdb) <$> [minBound .. maxBound] - CTOrC -> - C.bgroup "OrC Cases" $ (gasOrC pdb) <$> [minBound .. maxBound] - CTIfC -> - C.bgroup "IfC Cases" $ - [ gasIfC pdb b - | b <- [False, True] ] - CTEnforceC -> - C.bgroup "EnforceC Cases" $ (gasEnforceC pdb) <$> [minBound .. maxBound] - CTEnforceOneC -> C.bgroup "enforce one benchmarks" [] -- TODO - CTFilterC -> - C.bgroup "FilterC Cases" $ - [gasFilterCEmptyNElems pdb b 10 - | b <- [False, True] ] - CTAndQC -> - C.bgroup "AndQC Cases" $ - [ gasAndQC pdb b - | b <- [False, True] ] - CTOrQC -> - C.bgroup "OrQC Cases" $ - [ gasOrQC pdb b - | b <- [False, True] ] - CTNotQC -> - gasNotQC pdb - -- Builtin forms - CTMapC -> - gasMapC pdb - CTFoldC -> - gasFoldC pdb - CTZipC -> - gasZipC pdb - CTPreSelectC -> - gasPreSelectC pdb - CTPreFoldDbC -> - gasPreFoldDbC pdb - CTSelectC -> - gasSelectC pdb - CTFoldDbFilterC -> - gasFoldDbFilterC pdb - CTFoldDbMapC -> - gasFoldDbMapC pdb - CTReadC -> - gasReadC pdb - CTWriteC -> - gasWriteC pdb - CTWithDefaultReadC -> - gasWithDefaultReadC pdb - CTKeysC -> - gasKeysC pdb - CTCreateTableC -> - gasCreateTableC pdb - CTEmitEventC -> - gasEmitEventC pdb - CTDefineNamespaceC -> - gasDefineNamespaceC pdb - CTDefineKeysetC -> - gasDefineKeysetC pdb - CTObjC -> - gasObjC pdb - CTCapInvokeC -> - C.bgroup "CapInvokeC" - [ gasCapInvokeCUserGuard pdb - , gasCapInvokeCWithCapC pdb - , gasCapInvokeCWithCapAutoManaged pdb - , gasCapInvokeCWithCapCManaged pdb - , gasCapInvokeCApplyMgrFun pdb - , gasCapInvokeCUpdMgrFun pdb] - CTCapBodyC -> - gasCapBodyC pdb - CTCapPopC -> - C.bgroup "CapBodyC" [gasCapPopCInvoke pdb, gasCapPopCComposed pdb ] - CTDefPactStepC -> - -- Todo: defpactstep benchmarks - C.bgroup "DefPactStepC" [] - CTNestedDefPactStepC -> - -- Todo: nesteddefpactstepC benchmarks - C.bgroup "NestedDefPactStepC" [] - CTIgnoreValueC -> gasIgnoreValueC pdb - CTEnforceBoolC -> gasEnforceBoolC pdb - CTEnforcePactValueC -> - gasEnforcePactValueC pdb - CTModuleAdminC -> - gasModuleAdminC pdb - CTStackPopC -> gasStackPopC pdb - CTEnforceErrorC -> - gasEnforceBoolC pdb - CTMt -> C.bgroup "Mt" - [ gasMtReturnNoHandler pdb - , gasMtWithHandlerError pdb - , gasMtWithHandlerValue pdb] diff --git a/gasmodel/Pact/Core/GasModel/Utils.hs b/gasmodel/Pact/Core/GasModel/Utils.hs index 46a00abfd..d032a1347 100644 --- a/gasmodel/Pact/Core/GasModel/Utils.hs +++ b/gasmodel/Pact/Core/GasModel/Utils.hs @@ -13,7 +13,6 @@ import Data.Text (Text) import Data.Map.Strict(Map) import Data.Monoid import qualified Criterion as C -import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -39,19 +38,10 @@ import Pact.Core.IR.Eval.CEK.Types hiding (Eval) import qualified Pact.Core.IR.Eval.CEK as Eval type CoreDb = PactDb CoreBuiltin Info -type MachineResult = CEKReturn ExecRuntime CoreBuiltin Info -type ApplyContToVEnv = - ( EvalEnv CoreBuiltin Info - , EvalState CoreBuiltin Info - , Cont ExecRuntime CEKSmallStep CoreBuiltin Info - , CEKErrorHandler ExecRuntime CEKSmallStep CoreBuiltin Info - , CEKValue ExecRuntime CEKSmallStep CoreBuiltin Info) -benchmarkEnv :: BuiltinEnv ExecRuntime CEKSmallStep CoreBuiltin Info -benchmarkEnv = coreBuiltinEnv @ExecRuntime @CEKSmallStep -benchmarkBigStepEnv :: BuiltinEnv ExecRuntime CEKBigStep CoreBuiltin Info -benchmarkBigStepEnv = coreBuiltinEnv @ExecRuntime @CEKBigStep +benchmarkBigStepEnv :: BuiltinEnv ExecRuntime CoreBuiltin Info +benchmarkBigStepEnv = coreBuiltinEnv @ExecRuntime newtype NoNF a = NoNf a @@ -251,43 +241,6 @@ prepopulateDb pdb = do _ <- liftIO $ _pdbCommitTx pdb pure () -evaluateN - :: EvalEnv CoreBuiltin Info - -> EvalState CoreBuiltin Info - -> Text - -> Int - -> IO (Either (PactError Info) MachineResult, EvalState CoreBuiltin Info) -evaluateN evalEnv es source nSteps = runEvalM (ExecEnv evalEnv) es $ do - term <- compileTerm source - let pdb = _eePactDb evalEnv - ps = _eeDefPactStep evalEnv - env = CEKEnv { _cePactDb=pdb - , _ceLocal=mempty - , _ceInCap=False - , _ceDefPactStep=ps - , _ceBuiltins = benchmarkEnv } - step1 <- Eval.evaluateTermSmallStep Mt CEKNoHandler env term - evalNSteps (nSteps - 1) step1 - -isFinal :: MachineResult -> Bool -isFinal (CEKReturn Mt CEKNoHandler _) = True -isFinal _ = False - -evalStep :: MachineResult -> Eval MachineResult -evalStep c@(CEKReturn cont handler result) - | isFinal c = return c - | otherwise = Eval.returnCEK cont handler result -evalStep (CEKEvaluateTerm cont handler cekEnv term) = Eval.evaluateTermSmallStep cont handler cekEnv term - -unsafeEvalStep :: MachineResult -> Eval MachineResult -unsafeEvalStep (CEKReturn cont handler result) = Eval.returnCEK cont handler result -unsafeEvalStep (CEKEvaluateTerm cont handler cekEnv term) = Eval.evaluateTermSmallStep cont handler cekEnv term - -evalNSteps :: Int -> MachineResult -> Eval MachineResult -evalNSteps i c - | i <= 0 = return c - | otherwise = evalStep c >>= evalNSteps (i - 1) - compileTerm :: Text -> Eval (CoreTerm Info) @@ -401,76 +354,6 @@ dummyTx pdb initDbState bs = C.envWithCleanup (_pdbBeginTx pdb Transactional >> ignoreWrites :: PactDb b i -> PactDb b i ignoreWrites pdb = pdb { _pdbWrite = \_ _ _ _ -> pure () } --- Closures -unitClosureNullary :: CEKEnv ExecRuntime step CoreBuiltin Info -> Closure ExecRuntime step CoreBuiltin Info -unitClosureNullary env - = Closure - { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash - , _cloTypes = NullaryClosure - , _cloArity = 0 - , _cloTerm = unitConst - , _cloRType = Nothing - , _cloEnv = env - , _cloInfo = def} - - -unitClosureUnary :: CEKEnv ExecRuntime step CoreBuiltin Info -> Closure ExecRuntime step CoreBuiltin Info -unitClosureUnary env - = Closure - { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash - , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg" Nothing def]) - , _cloArity = 1 - , _cloTerm = unitConst - , _cloRType = Nothing - , _cloEnv = env - , _cloInfo = def} - -unitClosureBinary :: CEKEnv ExecRuntime step CoreBuiltin Info -> Closure ExecRuntime step CoreBuiltin Info -unitClosureBinary env - = Closure - { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash - , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing def, Arg "fooCloArg2" Nothing def]) - , _cloArity = 2 - , _cloTerm = unitConst - , _cloRType = Nothing - , _cloEnv = env - , _cloInfo = def} - - -boolClosureUnary :: Bool -> CEKEnv e step b Info -> Closure e step b Info -boolClosureUnary b env - = Closure - { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash - , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing def]) - , _cloArity = 1 - , _cloTerm = boolConst b - , _cloRType = Nothing - , _cloEnv = env - , _cloInfo = def} - -boolClosureBinary :: Bool -> CEKEnv e step b Info -> Closure e step b Info -boolClosureBinary b env - = Closure - { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash - , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing def, Arg "fooCloArg2" Nothing def]) - , _cloArity = 2 - , _cloTerm = boolConst b - , _cloRType = Nothing - , _cloEnv = env - , _cloInfo = def} - -intClosureBinary :: Integer -> CEKEnv e step b Info -> Closure e step b Info -intClosureBinary b env - = Closure - { _cloFqName = FullyQualifiedName (ModuleName "foomodule" Nothing) "foo" placeholderHash - , _cloTypes = ArgClosure (NE.fromList [Arg "fooCloArg1" Nothing def, Arg "fooCloArg2" Nothing def]) - , _cloArity = 2 - , _cloTerm = intConst b - , _cloRType = Nothing - , _cloEnv = env - , _cloInfo = def} - - unitConst :: CoreTerm Info unitConst = Constant LUnit def diff --git a/pact-lsp/Pact/Core/LanguageServer.hs b/pact-lsp/Pact/Core/LanguageServer.hs index 5602dde06..ca0ec343a 100644 --- a/pact-lsp/Pact/Core/LanguageServer.hs +++ b/pact-lsp/Pact/Core/LanguageServer.hs @@ -253,7 +253,7 @@ setupAndProcessFile nuri content = do , _replNativesEnabled = True } stateRef <- newIORef rstate - res <- runReplT stateRef (processFile Repl.interpretEvalSmallStep nuri content) + res <- runReplT stateRef (processFile Repl.interpretEvalBigStep nuri content) st <- readIORef stateRef pure $ (st,) <$> res where diff --git a/pact-tests/Pact/Core/Test/GasGolden.hs b/pact-tests/Pact/Core/Test/GasGolden.hs index 576c6bb34..3993ba7a9 100644 --- a/pact-tests/Pact/Core/Test/GasGolden.hs +++ b/pact-tests/Pact/Core/Test/GasGolden.hs @@ -37,7 +37,6 @@ tests = do pure $ testGroup "Gas Goldens" [ testCase "Capture all builtins" $ captureBuiltins (fst <$> cases) , goldenVsStringDiff "Gas Goldens: CEK" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretReplProgramBigStep) - , goldenVsStringDiff "Gas Goldens: CEK smallstep" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretReplProgramSmallStep) , goldenVsStringDiff "Gas Goldens: Direct" runDiff (gasTestDir "builtinGas.golden") (gasGoldenTests cases interpretReplProgramDirect) ] where diff --git a/pact-tests/Pact/Core/Test/ReplTests.hs b/pact-tests/Pact/Core/Test/ReplTests.hs index b5db4fb98..6ac0492dd 100644 --- a/pact-tests/Pact/Core/Test/ReplTests.hs +++ b/pact-tests/Pact/Core/Test/ReplTests.hs @@ -42,8 +42,6 @@ tests = do pure $ testGroup "ReplTests" [ testGroup "in-memory db:bigstep" (runFileReplTest interpretReplProgramBigStep <$> files) , testGroup "sqlite db:bigstep" (runFileReplTestSqlite interpretReplProgramBigStep <$> files) - , testGroup "in-memory db:smallstep" (runFileReplTest interpretReplProgramSmallStep <$> files) - , testGroup "sqlite db:smallstep" (runFileReplTestSqlite interpretReplProgramSmallStep <$> files) , testGroup "in-memory db:direct" (runFileReplTest interpretReplProgramDirect <$> files) , testGroup "sqlite db:direct" (runFileReplTestSqlite interpretReplProgramDirect <$> files) ] diff --git a/pact-tng.cabal b/pact-tng.cabal index b2623bd01..337ba5ed3 100644 --- a/pact-tng.cabal +++ b/pact-tng.cabal @@ -338,7 +338,6 @@ executable gasmodel other-modules: Pact.Core.GasModel.BuiltinsGas - Pact.Core.GasModel.InterpreterGas Pact.Core.GasModel.ContractBench Pact.Core.GasModel.Serialization Pact.Core.GasModel.Utils diff --git a/pact/Pact/Core/Evaluate.hs b/pact/Pact/Core/Evaluate.hs index b2be82503..0962efb05 100644 --- a/pact/Pact/Core/Evaluate.hs +++ b/pact/Pact/Core/Evaluate.hs @@ -83,8 +83,8 @@ evalInterpreter = runGuard info g = Eval.interpretGuard info cekEnv g resume info defPact = Eval.evalResumePact info cekEnv defPact -cekEnv :: Eval.BuiltinEnv ExecRuntime Eval.CEKBigStep CoreBuiltin i -cekEnv = coreBuiltinEnv @ExecRuntime @Eval.CEKBigStep +cekEnv :: Eval.BuiltinEnv ExecRuntime CoreBuiltin i +cekEnv = coreBuiltinEnv @ExecRuntime evalDirectInterpreter :: Interpreter ExecRuntime CoreBuiltin i evalDirectInterpreter = diff --git a/pact/Pact/Core/IR/Eval/CEK.hs b/pact/Pact/Core/IR/Eval/CEK.hs index fe7a1567a..b1f41a78a 100644 --- a/pact/Pact/Core/IR/Eval/CEK.hs +++ b/pact/Pact/Core/IR/Eval/CEK.hs @@ -35,10 +35,10 @@ module Pact.Core.IR.Eval.CEK , guardForModuleCall , enforceGuard , evalResumePact - , applyContSmallStep - , applyContToValueSmallStep - , evaluateTermSmallStep - , CEKEval(..) + , evalCEK + , returnCEKValue + , returnCEK + , applyLamUnsafe , module Pact.Core.IR.Eval.CEK.Types , module Pact.Core.IR.Eval.CEK.Utils , returnCEKError @@ -58,7 +58,6 @@ import qualified Data.Vector as V import qualified Data.Set as S import qualified Data.Map.Strict as M import qualified Data.List.NonEmpty as NE -import qualified Data.Kind as K #if !MIN_VERSION_base(4,20,0) import Data.List(foldl') #endif @@ -88,22 +87,6 @@ import Pact.Core.IR.Eval.CEK.Utils -class CEKEval (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) where - returnCEKValue :: Cont e step b i -> CEKErrorHandler e step b i -> CEKValue e step b i -> EvalM e b i (CEKEvalResult e step b i) - - returnCEK :: Cont e step b i -> CEKErrorHandler e step b i -> EvalResult e step b i -> EvalM e b i (CEKEvalResult e step b i) - - evalCEK :: Cont e step b i -> CEKErrorHandler e step b i -> CEKEnv e step b i -> EvalTerm b i -> EvalM e b i (CEKEvalResult e step b i) - - returnFinal :: EvalResult e step b i -> EvalM e b i (CEKEvalResult e step b i) - - evalNormalForm :: CEKEnv e step b i -> EvalTerm b i -> EvalM e b i (EvalResult e step b i) - - applyLamUnsafe :: CanApply e step b i -> [CEKValue e step b i] -> Cont e step b i -> CEKErrorHandler e step b i -> EvalM e b i (EvalResult e step b i) - - evalUnsafe :: CEKEvalResult e step b i -> EvalM e b i (EvalResult e step b i) - - {- Our CEKH Machine's transitions when reducing terms. `evaluateTerm` reduces a term and either directly produces a value, @@ -124,12 +107,11 @@ class CEKEval (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Typ K=Mt and H=NoHandler and returns a semantic value, or an error -} evaluateTerm - :: (CEKEval e step b i) - => Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + :: Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> EvalTerm b i - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) -- | ------ From ------ | ------ To ------ | -- -- @@ -319,8 +301,8 @@ evaluateTerm cont handler _env (InlineValue v _) = mkDefunClosure :: Defun Name Type b i -> FullyQualifiedName - -> CEKEnv e step b i - -> EvalM e b i (Closure e step b i) + -> CEKEnv e b i + -> EvalM e b i (Closure e b i) mkDefunClosure d fqn e = case _dfunTerm d of Lam args body i -> pure (Closure fqn (ArgClosure args) (NE.length args) body (_dfunRType d) e i) @@ -333,8 +315,8 @@ mkDefPactClosure :: i -> FullyQualifiedName -> DefPact Name Type b i - -> CEKEnv e step b i - ->CEKValue e step b i + -> CEKEnv e b i + ->CEKValue e b i mkDefPactClosure info fqn dpact env = case _dpArgs dpact of [] -> let dpc = DefPactClosure fqn NullaryClosure 0 env info @@ -344,13 +326,13 @@ mkDefPactClosure info fqn dpact env = case _dpArgs dpact of in VDefPactClosure dpc initPact - :: (CEKEval e step b i) + :: () => i -> DefPactContinuation QualifiedName PactValue - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i - -> EvalM e b i (CEKEvalResult e step b i) + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i + -> EvalM e b i (EvalResult e b i) initPact i pc cont handler cenv = do case view ceDefPactStep cenv of Nothing -> do @@ -370,15 +352,15 @@ initPact i pc cont handler cenv = do applyPact - :: (CEKEval e step b i) + :: () => i -> DefPactContinuation QualifiedName PactValue -> DefPactStep - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> M.Map DefPactId DefPactExec - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) applyPact i pc ps cont handler cenv nested = use esDefPactExec >>= \case Just pe -> throwExecutionError i (MultipleOrNestedDefPactExecFound pe) Nothing -> getModuleMemberWithHash i (_cePactDb cenv) (pc ^. pcName) >>= \case @@ -437,14 +419,14 @@ emitXChainEvents mResume dpe = do mh applyNestedPact - :: (CEKEval e step b i) + :: () => i -> DefPactContinuation QualifiedName PactValue -> DefPactStep - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i - -> EvalM e b i (CEKEvalResult e step b i) + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i + -> EvalM e b i (EvalResult e b i) applyNestedPact i pc ps cont handler cenv = use esDefPactExec >>= \case Nothing -> failInvariant i $ InvariantPactExecNotInEnv (Just pc) @@ -501,13 +483,13 @@ applyNestedPact i pc ps cont handler cenv = use esDefPactExec >>= \case resumePact - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> Maybe DefPactExec - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) resumePact i cont handler env crossChainContinuation = viewEvalEnv eeDefPactStep >>= \case Nothing -> throwExecutionError i DefPactStepNotInEnvironment -- TODO check with multichain Just ps -> do @@ -576,7 +558,7 @@ resumePact i cont handler env crossChainContinuation = viewEvalEnv eeDefPactStep -- Todo: is this enough checks for ndynref? nameToFQN :: i - -> CEKEnv e step b i + -> CEKEnv e b i -> Name -> EvalM e b i FullyQualifiedName nameToFQN info env (Name n nk) = case nk of @@ -590,14 +572,14 @@ nameToFQN info env (Name n nk) = case nk of _ -> failInvariant info (InvariantInvalidBoundVariable n) guardTable - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> TableValue -> GuardTableOp - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) guardTable i cont handler env (TableValue tn mh _) dbop = do let mn = _tableModuleName tn checkLocalBypass $ @@ -615,14 +597,14 @@ guardTable i cont handler env (TableValue tn mh _) dbop = do | otherwise -> notBypassed guardForModuleCall - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> ModuleName - -> EvalM e b i (CEKEvalResult e step b i) - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) + -> EvalM e b i (EvalResult e b i) guardForModuleCall i cont handler env currMod onFound = findCallingModule >>= \case Just mn | mn == currMod -> onFound @@ -636,13 +618,13 @@ guardForModuleCall i cont handler env currMod onFound = -- checking whether `esCaps . csModuleAdmin` for the particular -- module is in scope acquireModuleAdmin - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> EvalModule b i - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) acquireModuleAdmin i cont handler env mdl = do case _mGovernance mdl of KeyGov ksn -> do @@ -655,15 +637,15 @@ acquireModuleAdmin i cont handler env mdl = do -- | Evaluate a term with all the stack manipulation logic evalWithStackFrame - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> Maybe Type -> StackFrame i -> EvalTerm b i - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) evalWithStackFrame info cont handler env mty sf body = do cont' <- pushStackFrame info cont mty sf evalCEK cont' handler env body @@ -671,10 +653,10 @@ evalWithStackFrame info cont handler env mty sf body = do -- | Push a stack frame into the stack, and check it for recursion pushStackFrame :: i - -> Cont e step b i + -> Cont e b i -> Maybe Type -> StackFrame i - -> EvalM e b i (Cont e step b i) + -> EvalM e b i (Cont e b i) pushStackFrame info cont mty sf = do checkRecursion esStack %= (sf :) @@ -704,16 +686,16 @@ pushStackFrame info cont mty sf = do -- - If the cap is managed, install the cap (If possible) then evaluate the body, and if -- the cap is user managed, ensure that the manager function run after the cap body evalCap - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> FQCapToken -> CapPopState -> EvalCapType -> EvalTerm b i - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType contbody = do capInStack <- isCapInStack' origToken if not capInStack then go else evalCEK currCont handler env contbody @@ -837,12 +819,12 @@ evalCap info currCont handler env origToken@(CapToken fqn args) popType ecType c _ -> failInvariant info (InvariantInvalidManagedCapKind "expected automanaged, received user managed") returnCEKError - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i + -> Cont e b i + -> CEKErrorHandler e b i -> UserRecoverableError - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) returnCEKError info cont handler err = do stack <- use esStack returnCEK cont handler (VError stack err info) @@ -850,19 +832,19 @@ returnCEKError info cont handler err = do enforceNotWithinDefcap :: i - -> CEKEnv e step b i + -> CEKEnv e b i -> T.Text -> EvalM e b i () enforceNotWithinDefcap info env form = when (_ceInCap env) $ throwExecutionError info (FormIllegalWithinDefcap form) requireCap - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i + -> Cont e b i + -> CEKErrorHandler e b i -> FQCapToken - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) requireCap info cont handler (CapToken fqn args) = do let qualCapToken = CapToken (fqnToQualName fqn) args capInStack <- isCapInStack qualCapToken @@ -881,13 +863,13 @@ isCapInStack' (CapToken fqn args) = isCapInStack (CapToken (fqnToQualName fqn) args) composeCap - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> FQCapToken - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) composeCap info cont handler env origToken = isCapInStack' origToken >>= \case False -> @@ -906,7 +888,7 @@ findMsgSigCap cix ct1 ct2 = -- `capAutonomous` are what we should use to match semantics accurately. installCap :: i - -> CEKEnv e step b i + -> CEKEnv e b i -> FQCapToken -> Bool -> EvalM e b i (ManagedCap QualifiedName PactValue) @@ -941,13 +923,13 @@ installCap info _env (CapToken fqn args) autonomous = do -- Todo: should we typecheck / arity check here? createUserGuard - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i + -> Cont e b i + -> CEKErrorHandler e b i -> FullyQualifiedName -> [PactValue] - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) createUserGuard info cont handler fqn args = do -- Note: we could use `getDefun` here, but this gives us a better error lookupFqName fqn >>= \case @@ -964,14 +946,14 @@ createUserGuard info cont handler fqn args = do applyCont - :: (CEKEval e step b i) - => Cont e step b i - -> CEKErrorHandler e step b i - -> EvalResult e step b i - -> EvalM e b i (CEKEvalResult e step b i) + :: () + => Cont e b i + -> CEKErrorHandler e b i + -> EvalResult e b i + -> EvalM e b i (EvalResult e b i) applyCont Mt handler v = case handler of - CEKNoHandler -> returnFinal v + CEKNoHandler -> pure v CEKHandler env catchTerm cont' errState handler' -> case v of VError{} -> do modify' (restoreFromErrorState errState) @@ -1015,14 +997,14 @@ applyCont cont handler v = case v of -- | if true then 1 else 2 applyContToValue - :: forall e step b i.(CEKEval e step b i) - => Cont e step b i - -> CEKErrorHandler e step b i - -> CEKValue e step b i - -> EvalM e b i (CEKEvalResult e step b i) + :: forall e b i.() + => Cont e b i + -> CEKErrorHandler e b i + -> CEKValue e b i + -> EvalM e b i (EvalResult e b i) applyContToValue Mt handler v = case handler of - CEKNoHandler -> returnFinal (EvalValue v) + CEKNoHandler -> pure (EvalValue v) -- Assuming no error, the caps will have been popped naturally CEKHandler _env _term cont' _ handler' -> returnCEKValue cont' handler' v @@ -1431,12 +1413,12 @@ nestedPactsNotAdvanced resultState ps = -- | Apply a closure to its arguments, -- dispatching based on closure type. applyLam - :: (CEKEval e step b i) - => CanApply e step b i - -> [CEKValue e step b i] - -> Cont e step b i - -> CEKErrorHandler e step b i - -> EvalM e b i (CEKEvalResult e step b i) + :: () + => CanApply e b i + -> [CEKValue e b i] + -> Cont e b i + -> CEKErrorHandler e b i + -> EvalM e b i (EvalResult e b i) applyLam vc@(C (Closure fqn ca arity term mty env cloi)) args cont handler -- Fully apply closure and evaluate | arity == argLen = case ca of @@ -1582,58 +1564,61 @@ applyLam (CT (CapTokenClosure fqn argtys arity i)) args cont handler -instance CEKEval e CEKSmallStep b i where - returnCEKValue cont handler v = pure (CEKReturn cont handler (EvalValue v)) - returnCEK cont handler v = pure (CEKReturn cont handler v) - evalCEK cont handler env term = pure (CEKEvaluateTerm cont handler env term) - returnFinal v = pure (CEKReturn Mt CEKNoHandler v) - applyLamUnsafe ca vs lc lh = applyLam ca vs lc lh >>= evalUnsafe +-- instance CEKEval e CEKSmallStep b i where +-- returnCEKValue cont handler v = pure (CEKReturn cont handler (EvalValue v)) +-- returnCEK cont handler v = pure (CEKReturn cont handler v) +-- evalCEK cont handler env term = pure (CEKEvaluateTerm cont handler env term) +-- returnFinal v = pure (CEKReturn Mt CEKNoHandler v) +-- applyLamUnsafe ca vs lc lh = applyLam ca vs lc lh >>= evalUnsafe - evalNormalForm initialEnv initialTerm = evalUnsafe (CEKEvaluateTerm Mt CEKNoHandler initialEnv initialTerm) - evalUnsafe (CEKReturn Mt CEKNoHandler result) = - return result - evalUnsafe (CEKReturn cont handler (EvalValue v)) = - applyContToValue cont handler v >>= evalUnsafe - evalUnsafe (CEKReturn cont handler result) = - applyCont cont handler result >>= evalUnsafe - evalUnsafe (CEKEvaluateTerm cont handler env term) = - evaluateTerm cont handler env term >>= evalUnsafe +-- evalNormalForm initialEnv initialTerm = evalUnsafe (CEKEvaluateTerm Mt CEKNoHandler initialEnv initialTerm) +-- evalUnsafe (CEKReturn Mt CEKNoHandler result) = +-- return result +-- evalUnsafe (CEKReturn cont handler (EvalValue v)) = +-- applyContToValue cont handler v >>= evalUnsafe +-- evalUnsafe (CEKReturn cont handler result) = +-- applyCont cont handler result >>= evalUnsafe +-- evalUnsafe (CEKEvaluateTerm cont handler env term) = +-- evaluateTerm cont handler env term >>= evalUnsafe -instance CEKEval e CEKBigStep b i where - returnCEKValue = applyContToValue - {-# INLINE returnCEKValue #-} +-- instance CEKEval e CEKBigStep b i where +returnCEKValue :: Cont e b i -> CEKErrorHandler e b i -> CEKValue e b i -> EvalM e b i (EvalResult e b i) +returnCEKValue = applyContToValue +{-# INLINE returnCEKValue #-} - returnCEK = applyCont - {-# INLINE returnCEK #-} +returnCEK :: Cont e b i -> CEKErrorHandler e b i -> EvalResult e b i -> EvalM e b i (EvalResult e b i) +returnCEK = applyCont +{-# INLINE returnCEK #-} - evalCEK = evaluateTerm - {-# INLINE evalCEK #-} +evalCEK :: Cont e b i -> CEKErrorHandler e b i -> CEKEnv e b i -> EvalTerm b i -> EvalM e b i (EvalResult e b i) +evalCEK = evaluateTerm +{-# INLINE evalCEK #-} - returnFinal = return - {-# INLINE returnFinal #-} - applyLamUnsafe = applyLam - {-# INLINE applyLamUnsafe #-} +applyLamUnsafe :: CanApply e b i -> [CEKValue e b i] -> Cont e b i -> CEKErrorHandler e b i -> EvalM e b i (EvalResult e b i) +applyLamUnsafe = applyLam +{-# INLINE applyLamUnsafe #-} - evalNormalForm = evaluateTerm Mt CEKNoHandler - {-# INLINE evalNormalForm #-} +evalNormalForm :: CEKEnv e b i -> EvalTerm b i -> EvalM e b i (EvalResult e b i) +evalNormalForm = evaluateTerm Mt CEKNoHandler +{-# INLINE evalNormalForm #-} - evalUnsafe = pure - {-# INLINE evalUnsafe #-} +-- evalUnsafe = pure +-- {-# INLINE evalUnsafe #-} -- | The main logic of enforcing a guard. -- --- The main difference to `coreEnforceGuard` is this function's type doesn't need to be a `NativeFunction e step b i`, +-- The main difference to `coreEnforceGuard` is this function's type doesn't need to be a `NativeFunction e b i`, -- thus there's no need to wrap/unwrap the guard into a `VPactValue`, -- and moreover it does not need to take a `b` which it does not use anyway. enforceGuard - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> Guard QualifiedName PactValue - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) enforceGuard info cont handler env g = case g of GKeyset ks -> do isKeysetInSigs info cont handler env ks @@ -1656,12 +1641,12 @@ enforceGuard info cont handler env g = case g of CapabilityPactGuardInvalidPactId curDpid dpid enforceCapGuard - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i + -> Cont e b i + -> CEKErrorHandler e b i -> CapabilityGuard QualifiedName PactValue - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) enforceCapGuard info cont handler cg@(CapabilityGuard qn args mpid) = case mpid of Nothing -> enforceCap Just pid -> do @@ -1678,13 +1663,13 @@ enforceCapGuard info cont handler cg@(CapabilityGuard qn args mpid) = case mpid runUserGuard - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> UserGuard QualifiedName PactValue - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) runUserGuard info cont handler env (UserGuard qn args) = getModuleMemberWithHash info (_cePactDb env) qn >>= \case (Dfun d, mh) -> do @@ -1697,10 +1682,10 @@ runUserGuard info cont handler env (UserGuard qn args) = eval - :: forall e step b i - . (CEKEval e step b i) + :: forall e b i + . () => Purity - -> BuiltinEnv e step b i + -> BuiltinEnv e b i -> EvalTerm b i -> EvalM e b i PactValue eval purity benv term = do @@ -1716,10 +1701,10 @@ eval purity benv term = do throwExecutionError (view termInfo term) (EvalError "Evaluation did not reduce to a value") evalWithinCap - :: forall e step b i - . (CEKEval e step b i) + :: forall e b i + . () => Purity - -> BuiltinEnv e step b i + -> BuiltinEnv e b i -> CapToken FullyQualifiedName PactValue -> EvalTerm b i -> EvalM e b i PactValue @@ -1727,7 +1712,6 @@ evalWithinCap purity benv ct term = do ee <- viewEvalEnv id let cekEnv = envFromPurity purity (CEKEnv mempty (_eePactDb ee) benv (_eeDefPactStep ee) False) evalCap (view termInfo term) Mt CEKNoHandler cekEnv ct PopCapInvoke NormalCapEval term - >>= evalUnsafe @e @step >>= \case VError stack err i -> throwUserRecoverableError' i stack err @@ -1738,16 +1722,16 @@ evalWithinCap purity benv ct term = do throwExecutionError (view termInfo term) (EvalError "Evaluation did not reduce to a value") interpretGuard - :: forall e step b i - . (CEKEval e step b i) + :: forall e b i + . () => i - -> BuiltinEnv e step b i + -> BuiltinEnv e b i -> Guard QualifiedName PactValue -> EvalM e b i PactValue interpretGuard info bEnv g = do ee <- viewEvalEnv id let cekEnv = CEKEnv mempty (_eePactDb ee) bEnv (_eeDefPactStep ee) False - enforceGuard info Mt CEKNoHandler cekEnv g >>= evalUnsafe @e @step >>= \case + enforceGuard info Mt CEKNoHandler cekEnv g >>= \case VError stack err i -> throwUserRecoverableError' i stack err EvalValue v -> do @@ -1757,17 +1741,17 @@ interpretGuard info bEnv g = do throwExecutionError info (EvalError "Evaluation did not reduce to a value") evalResumePact - :: forall e step b i - . (CEKEval e step b i) + :: forall e b i + . () => i - -> BuiltinEnv e step b i + -> BuiltinEnv e b i -> Maybe DefPactExec -> EvalM e b i PactValue evalResumePact info bEnv mdpe = do ee <- viewEvalEnv id let pdb = _eePactDb ee let env = CEKEnv mempty pdb bEnv (_eeDefPactStep ee) False - resumePact info Mt CEKNoHandler env mdpe >>= evalUnsafe @e @step >>= \case + resumePact info Mt CEKNoHandler env mdpe >>= \case VError stack err i -> throwUserRecoverableError' i stack err EvalValue v -> do @@ -1777,39 +1761,15 @@ evalResumePact info bEnv mdpe = do throwExecutionError info (EvalError "Evaluation did not reduce to a value") -evaluateTermSmallStep - :: Cont e CEKSmallStep CoreBuiltin a - -> CEKErrorHandler e CEKSmallStep CoreBuiltin a - -> CEKEnv e CEKSmallStep CoreBuiltin a - -> CoreTerm a - -> EvalM e CoreBuiltin a (CEKReturn e CoreBuiltin a) -evaluateTermSmallStep = evaluateTerm - - -applyContToValueSmallStep - :: Cont e CEKSmallStep CoreBuiltin a - -> CEKErrorHandler e CEKSmallStep CoreBuiltin a - -> CEKValue e CEKSmallStep CoreBuiltin a - -> EvalM e CoreBuiltin a (CEKReturn e CoreBuiltin a) -applyContToValueSmallStep = applyContToValue - - -applyContSmallStep - :: Cont e CEKSmallStep CoreBuiltin a - -> CEKErrorHandler e CEKSmallStep CoreBuiltin a - -> EvalResult e CEKSmallStep CoreBuiltin a - -> EvalM e CoreBuiltin a (CEKReturn e CoreBuiltin a) -applyContSmallStep = applyCont - -- Keyset Code isKeysetInSigs - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> KeySet - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) isKeysetInSigs info cont handler env ks@(KeySet kskeys ksPred) = do matchedSigs <- M.filterWithKey matchKey <$> viewEvalEnv eeMsgSigs sigs <- checkSigCaps matchedSigs @@ -1850,13 +1810,13 @@ isKeysetInSigs info cont handler env ks@(KeySet kskeys ksPred) = do throwExecutionError info (InvalidCustomKeysetPredicate "expected native") isKeysetNameInSigs - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> KeySetName - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) isKeysetNameInSigs info cont handler env ksn = do pdb <- viewEvalEnv eePactDb liftDbFunction info (_pdbRead pdb DKeySets ksn) >>= \case diff --git a/pact/Pact/Core/IR/Eval/CEK/Types.hs b/pact/Pact/Core/IR/Eval/CEK/Types.hs index 3413e176b..3d20b7ccd 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Types.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Types.hs @@ -77,9 +77,6 @@ module Pact.Core.IR.Eval.CEK.Types , ClosureType(..) , ErrorState(..) , BuiltinCont(..) - , CEKReturn(..) - , CEKEvalResult - , CEKStepKind(..) , ContType(..) , Eval , CoreTerm @@ -127,34 +124,34 @@ import Pact.Core.IR.Eval.Runtime.Types import qualified Pact.Core.Pretty as P -data CEKReturn e b i - = CEKEvaluateTerm (Cont e CEKSmallStep b i) (CEKErrorHandler e CEKSmallStep b i) (CEKEnv e CEKSmallStep b i) (EvalTerm b i) - | CEKReturn (Cont e CEKSmallStep b i) (CEKErrorHandler e CEKSmallStep b i) (EvalResult e CEKSmallStep b i) - deriving (Show, Generic) +-- data CEKReturn e b i +-- = CEKEvaluateTerm (Cont e CEKSmallStep b i) (CEKErrorHandler e CEKSmallStep b i) (CEKEnv e CEKSmallStep b i) (EvalTerm b i) +-- | CEKReturn (Cont e CEKSmallStep b i) (CEKErrorHandler e CEKSmallStep b i) (EvalResult e CEKSmallStep b i) +-- deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (CEKReturn e b i) +-- instance (NFData b, NFData i) => NFData (CEKReturn e b i) -- | The top level env map type CEKTLEnv b i = Map FullyQualifiedName (EvalDef b i) -- | Locally bound variables -data CEKEnv (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data CEKEnv (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = CEKEnv - { _ceLocal :: RAList (CEKValue e step b i) + { _ceLocal :: RAList (CEKValue e b i) , _cePactDb :: PactDb b i - , _ceBuiltins :: BuiltinEnv e step b i + , _ceBuiltins :: BuiltinEnv e b i , _ceDefPactStep :: Maybe DefPactStep , _ceInCap :: Bool } deriving (Generic) -instance (NFData b, NFData i) => NFData (CEKEnv e step b i) +instance (NFData b, NFData i) => NFData (CEKEnv e b i) -instance (Show i, Show b) => Show (CEKEnv e step b i) where +instance (Show i, Show b) => Show (CEKEnv e b i) where show (CEKEnv e _ _ _ _) = show e -- | List of builtins -type BuiltinEnv (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) - = i -> b -> CEKEnv e step b i -> NativeFn e step b i +type BuiltinEnv (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) + = i -> b -> CEKEnv e b i -> NativeFn e b i data ClosureType i @@ -164,59 +161,59 @@ data ClosureType i instance NFData i => NFData (ClosureType i) -data Closure (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data Closure (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = Closure { _cloFqName :: !FullyQualifiedName , _cloTypes :: !(ClosureType i) , _cloArity :: !Int , _cloTerm :: !(EvalTerm b i) , _cloRType :: !(Maybe Type) - , _cloEnv :: !(CEKEnv e step b i) + , _cloEnv :: !(CEKEnv e b i) , _cloInfo :: i } deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (Closure e step b i) +instance (NFData b, NFData i) => NFData (Closure e b i) -- | A closure coming from a lambda application with its accompanying environment capturing args, -- but is not partially applied -data LamClosure (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data LamClosure (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = LamClosure { _lcloTypes :: !(ClosureType i) , _lcloArity :: !Int , _lcloTerm :: !(EvalTerm b i) , _lcloRType :: !(Maybe Type) - , _lcloEnv :: !(CEKEnv e step b i) + , _lcloEnv :: !(CEKEnv e b i) , _lcloInfo :: i } deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (LamClosure e step b i) +instance (NFData b, NFData i) => NFData (LamClosure e b i) -- | A partially applied function because we don't allow -- them to be applied at the lhs of an app since pact historically hasn't had partial closures. -- This is a bit annoying to deal with but helps preserve semantics -data PartialClosure (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data PartialClosure (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = PartialClosure { _pcloFrame :: !(Maybe (StackFrame i)) , _pcloTypes :: !(NonEmpty (Arg Type i)) , _pcloArity :: !Int , _pcloTerm :: !(EvalTerm b i) , _pcloRType :: !(Maybe Type) - , _pcloEnv :: !(CEKEnv e step b i) + , _pcloEnv :: !(CEKEnv e b i) , _pcloInfo :: i } deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (PartialClosure e step b i) +instance (NFData b, NFData i) => NFData (PartialClosure e b i) -data DefPactClosure (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data DefPactClosure (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = DefPactClosure { _pactcloFQN :: !FullyQualifiedName , _pactcloTypes :: !(ClosureType i) , _pactcloArity :: !Int - , _pactEnv :: !(CEKEnv e step b i) + , _pactEnv :: !(CEKEnv e b i) , _pactcloInfo :: i } deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (DefPactClosure e step b i) +instance (NFData b, NFData i) => NFData (DefPactClosure e b i) data CapTokenClosure i = CapTokenClosure @@ -228,134 +225,134 @@ data CapTokenClosure i instance NFData i => NFData (CapTokenClosure i) -data CanApply (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) - = C !(Closure e step b i) - | N !(NativeFn e step b i) +data CanApply (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) + = C !(Closure e b i) + | N !(NativeFn e b i) | CT !(CapTokenClosure i) - | LC !(LamClosure e step b i) - | PC !(PartialClosure e step b i) - | PN !(PartialNativeFn e step b i) - | DPC !(DefPactClosure e step b i) + | LC !(LamClosure e b i) + | PC !(PartialClosure e b i) + | PN !(PartialNativeFn e b i) + | DPC !(DefPactClosure e b i) deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (CanApply e step b i) +instance (NFData b, NFData i) => NFData (CanApply e b i) -- | The type of our semantic runtime values -data CEKValue (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data CEKValue (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = VPactValue !PactValue -- ^ PactValue(s), which contain no terms | VTable !TableValue -- ^ Table references, which despite being a syntactic -- value with - | VClosure !(CanApply e step b i) + | VClosure !(CanApply e b i) -- ^ Closures, which may contain terms deriving (Generic) -instance (NFData b, NFData i) => NFData (CEKValue e step b i) +instance (NFData b, NFData i) => NFData (CEKValue e b i) -instance Show (CEKValue e step b i) where +instance Show (CEKValue e b i) where show = \case VPactValue pv -> show pv VTable vt -> "table" <> show (_tvName vt) VClosure _ -> "closure<>" -pattern VLiteral :: Literal -> CEKValue e step b i +pattern VLiteral :: Literal -> CEKValue e b i pattern VLiteral lit = VPactValue (PLiteral lit) -pattern VString :: Text -> CEKValue e step b i +pattern VString :: Text -> CEKValue e b i pattern VString txt = VLiteral (LString txt) -pattern VInteger :: Integer -> CEKValue e step b i +pattern VInteger :: Integer -> CEKValue e b i pattern VInteger txt = VLiteral (LInteger txt) -pattern VUnit :: CEKValue e step b i +pattern VUnit :: CEKValue e b i pattern VUnit = VLiteral LUnit -pattern VBool :: Bool -> CEKValue e step b i +pattern VBool :: Bool -> CEKValue e b i pattern VBool b = VLiteral (LBool b) -pattern VDecimal :: Decimal -> CEKValue e step b i +pattern VDecimal :: Decimal -> CEKValue e b i pattern VDecimal d = VLiteral (LDecimal d) -pattern VGuard :: Guard QualifiedName PactValue -> CEKValue e step b i +pattern VGuard :: Guard QualifiedName PactValue -> CEKValue e b i pattern VGuard g = VPactValue (PGuard g) -pattern VList :: Vector PactValue -> CEKValue e step b i +pattern VList :: Vector PactValue -> CEKValue e b i pattern VList p = VPactValue (PList p) -pattern VTime :: UTCTime -> CEKValue e step b i +pattern VTime :: UTCTime -> CEKValue e b i pattern VTime p = VPactValue (PTime p) -pattern VObject :: Map Field PactValue -> CEKValue e step b i +pattern VObject :: Map Field PactValue -> CEKValue e b i pattern VObject o = VPactValue (PObject o) -pattern VModRef :: ModRef -> CEKValue e step b i +pattern VModRef :: ModRef -> CEKValue e b i pattern VModRef mn = VPactValue (PModRef mn) -pattern VCapToken :: CapToken FullyQualifiedName PactValue -> CEKValue e step b i +pattern VCapToken :: CapToken FullyQualifiedName PactValue -> CEKValue e b i pattern VCapToken ct = VPactValue (PCapToken ct) -pattern VNative :: NativeFn e step b i -> CEKValue e step b i +pattern VNative :: NativeFn e b i -> CEKValue e b i pattern VNative clo = VClosure (N clo) -pattern VPartialNative :: PartialNativeFn e step b i -> CEKValue e step b i +pattern VPartialNative :: PartialNativeFn e b i -> CEKValue e b i pattern VPartialNative clo = VClosure (PN clo) -pattern VDefClosure :: Closure e step b i -> CEKValue e step b i +pattern VDefClosure :: Closure e b i -> CEKValue e b i pattern VDefClosure clo = VClosure (C clo) -pattern VLamClosure :: LamClosure e step b i -> CEKValue e step b i +pattern VLamClosure :: LamClosure e b i -> CEKValue e b i pattern VLamClosure clo = VClosure (LC clo) -pattern VPartialClosure :: PartialClosure e step b i -> CEKValue e step b i +pattern VPartialClosure :: PartialClosure e b i -> CEKValue e b i pattern VPartialClosure clo = VClosure (PC clo) -pattern VDefPactClosure :: DefPactClosure e step b i -> CEKValue e step b i +pattern VDefPactClosure :: DefPactClosure e b i -> CEKValue e b i pattern VDefPactClosure clo = VClosure (DPC clo) -- | Result of an evaluation step, either a CEK value or an error. -data EvalResult (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) - = EvalValue (CEKValue e step b i) +data EvalResult (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) + = EvalValue (CEKValue e b i) | VError [StackFrame i] UserRecoverableError i deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (EvalResult e step b i) +instance (NFData b, NFData i) => NFData (EvalResult e b i) -type NativeFunction (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) - = i -> b -> Cont e step b i -> CEKErrorHandler e step b i -> CEKEnv e step b i -> [CEKValue e step b i] -> EvalM e b i (CEKEvalResult e step b i) +type NativeFunction (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) + = i -> b -> Cont e b i -> CEKErrorHandler e b i -> CEKEnv e b i -> [CEKValue e b i] -> EvalM e b i (EvalResult e b i) -data NativeFn (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data NativeFn (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = NativeFn { _native :: !b - , _nativeEnv :: !(CEKEnv e step b i) - , _nativeFn :: !(NativeFunction e step b i) + , _nativeEnv :: !(CEKEnv e b i) + , _nativeFn :: !(NativeFunction e b i) , _nativeArity :: !Int , _nativeLoc :: !i } deriving (Generic) -instance (NFData b, NFData i) => NFData (NativeFn e step b i) +instance (NFData b, NFData i) => NFData (NativeFn e b i) -- | A partially applied native because we don't allow -- them to be applied at the lhs of an app since pact historically hasn't had partial closures. -- This is a bit annoying to deal with but helps preserve semantics -data PartialNativeFn (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data PartialNativeFn (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = PartialNativeFn { _pNative :: !b - , _pNativeEnv :: !(CEKEnv e step b i) - , _pNativeFn :: !(NativeFunction e step b i) + , _pNativeEnv :: !(CEKEnv e b i) + , _pNativeFn :: !(NativeFunction e b i) , _pNativeArity :: !Int - , _pNativeAppliedArgs :: ![CEKValue e step b i] + , _pNativeAppliedArgs :: ![CEKValue e b i] , _pNativeLoc :: !i } deriving (Generic) -instance (NFData b, NFData i) => NFData (PartialNativeFn e step b i) +instance (NFData b, NFData i) => NFData (PartialNativeFn e b i) -- | Continuation Frames that handle conditional argument returns in a lazy manner. -data CondCont (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data CondCont (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = AndC (EvalTerm b i) -- ^ | OrC (EvalTerm b i) @@ -366,39 +363,39 @@ data CondCont (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Typ -- ^ | EnforceOneC -- ^ [] - | FilterC (CanApply e step b i) PactValue [PactValue] [PactValue] + | FilterC (CanApply e b i) PactValue [PactValue] [PactValue] -- ^ {filtering closure} - | AndQC (CanApply e step b i) PactValue + | AndQC (CanApply e b i) PactValue -- ^ {bool comparison closure} - | OrQC (CanApply e step b i) PactValue + | OrQC (CanApply e b i) PactValue -- ^ {bool comparison closure} | NotQC -- ^ Nada deriving (Show, Generic) -data BuiltinCont (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) - = MapC (CanApply e step b i) [PactValue] [PactValue] +data BuiltinCont (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) + = MapC (CanApply e b i) [PactValue] [PactValue] -- ^ {closure} {remaining} {accum} - | FoldC (CanApply e step b i) [PactValue] + | FoldC (CanApply e b i) [PactValue] -- ^ {closure} {accum} {rest} - | ZipC (CanApply e step b i) ([PactValue],[PactValue]) [PactValue] + | ZipC (CanApply e b i) ([PactValue],[PactValue]) [PactValue] -- ^ - | PreSelectC TableValue (CanApply e step b i) (Maybe [Field]) + | PreSelectC TableValue (CanApply e b i) (Maybe [Field]) -- ^
- | FoldDbFilterC TableValue (CanApply e step b i) (CanApply e step b i) (RowKey, ObjectData PactValue) [RowKey] [(RowKey, PactValue)] + | FoldDbFilterC TableValue (CanApply e b i) (CanApply e b i) (RowKey, ObjectData PactValue) [RowKey] [(RowKey, PactValue)] -- ^
- | FoldDbMapC TableValue (CanApply e step b i) [(RowKey, PactValue)] [PactValue] + | FoldDbMapC TableValue (CanApply e b i) [(RowKey, PactValue)] [PactValue] -- ^
| ReadC TableValue RowKey -- ^
| WriteC TableValue WriteType RowKey (ObjectData PactValue) -- ^
-- ^
- | WithDefaultReadC TableValue RowKey (ObjectData PactValue) (CanApply e step b i) + | WithDefaultReadC TableValue RowKey (ObjectData PactValue) (CanApply e b i) -- ^
| KeysC TableValue -- ^ Table to apply `keys` to @@ -422,9 +419,9 @@ data BuiltinCont (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K. -- | Control flow around Capability special forms, in particular cap token forms -data CapCont (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data CapCont (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = WithCapC (EvalTerm b i) - | ApplyMgrFunC (ManagedCap QualifiedName PactValue) (Closure e step b i) PactValue PactValue + | ApplyMgrFunC (ManagedCap QualifiedName PactValue) (Closure e b i) PactValue PactValue -- ^ ^mgr closure ^ old value ^ new value | UpdateMgrFunC (ManagedCap QualifiedName PactValue) | CreateUserGuardC FullyQualifiedName [EvalTerm b i] [PactValue] @@ -450,61 +447,61 @@ data CapBodyState b i instance (NFData b, NFData i) => NFData (CapBodyState b i) -data Cont (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data Cont (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = Mt -- ^ Empty Continuation - | Fn !(CanApply e step b i) !(CEKEnv e step b i) ![EvalTerm b i] ![CEKValue e step b i] !(Cont e step b i) + | Fn !(CanApply e b i) !(CEKEnv e b i) ![EvalTerm b i] ![CEKValue e b i] !(Cont e b i) -- ^ Continuation which evaluates arguments for a function to apply - | Args !(CEKEnv e step b i) i ![EvalTerm b i] !(Cont e step b i) + | Args !(CEKEnv e b i) i ![EvalTerm b i] !(Cont e b i) -- ^ Continuation holding the arguments to evaluate in a function application - | LetC !(CEKEnv e step b i) !(EvalTerm b i) !(Cont e step b i) + | LetC !(CEKEnv e b i) !(EvalTerm b i) !(Cont e b i) -- ^ Let single-variable pushing -- Optimization frame: Bypasses closure creation and thus less alloc -- Known as a single argument it will not construct a needless closure - | SeqC (CEKEnv e step b i) (EvalTerm b i) (Cont e step b i) + | SeqC (CEKEnv e b i) (EvalTerm b i) (Cont e b i) -- ^ Sequencing expression, holding the next term to evaluate - | ListC (CEKEnv e step b i) i [EvalTerm b i] [PactValue] (Cont e step b i) + | ListC (CEKEnv e b i) i [EvalTerm b i] [PactValue] (Cont e b i) -- ^ Continuation for list elements - | CondC (CEKEnv e step b i) i (CondCont e step b i) (Cont e step b i) + | CondC (CEKEnv e b i) i (CondCont e b i) (Cont e b i) -- ^ Continuation for conditionals with lazy semantics - | BuiltinC (CEKEnv e step b i) i (BuiltinCont e step b i) (Cont e step b i) + | BuiltinC (CEKEnv e b i) i (BuiltinCont e b i) (Cont e b i) -- ^ Continuation for higher-order function builtins - | ObjC (CEKEnv e step b i) i Field [(Field, EvalTerm b i)] [(Field, PactValue)] (Cont e step b i) + | ObjC (CEKEnv e b i) i Field [(Field, EvalTerm b i)] [(Field, PactValue)] (Cont e b i) -- Todo: merge all cap constructors -- ^ Continuation for the current object field being evaluated, and the already evaluated pairs - | CapInvokeC (CEKEnv e step b i) i (CapCont e step b i) (Cont e step b i) + | CapInvokeC (CEKEnv e b i) i (CapCont e b i) (Cont e b i) -- ^ Frame for control flow around argument reduction to with-capability and create-user-guard - | CapBodyC (CEKEnv e step b i) i !(CapBodyState b i) (Cont e step b i) + | CapBodyC (CEKEnv e b i) i !(CapBodyState b i) (Cont e b i) -- ^ CapBodyC includes -- - what to do after the cap body (pop it, or compose it) -- - Is it a user managed cap? If so, include the body token -- - the capability "user body" to evaluate, generally carrying a series of expressions -- or a simple return value in the case of `compose-capability` -- - The rest of the continuation - | CapPopC CapPopState i (Cont e step b i) + | CapPopC CapPopState i (Cont e b i) -- ^ What to do after returning from a defcap: do we compose the returned cap, or do we simply pop it from the stack - | DefPactStepC (CEKEnv e step b i) i (Cont e step b i) + | DefPactStepC (CEKEnv e b i) i (Cont e b i) -- ^ Cont frame after a defpact, ensuring we save the defpact to the database and whatnot - | NestedDefPactStepC (CEKEnv e step b i) i (Cont e step b i) DefPactExec + | NestedDefPactStepC (CEKEnv e b i) i (Cont e b i) DefPactExec -- ^ Frame for control flow around nested defpact execution - | IgnoreValueC PactValue (Cont e step b i) + | IgnoreValueC PactValue (Cont e b i) -- ^ Frame to ignore value after user guard execution - | EnforceBoolC i (Cont e step b i) + | EnforceBoolC i (Cont e b i) -- ^ Enforce boolean - | EnforcePactValueC i (Cont e step b i) + | EnforcePactValueC i (Cont e b i) -- ^ Enforce pact value - | ModuleAdminC ModuleName (Cont e step b i) + | ModuleAdminC ModuleName (Cont e b i) -- ^ Add module admin on successful cap eval - | StackPopC i (Maybe Type) (Cont e step b i) + | StackPopC i (Maybe Type) (Cont e b i) -- ^ Pop the current stack frame and check the return value for the declared type - | EnforceErrorC i (Cont e step b i) + | EnforceErrorC i (Cont e b i) -- ^ Continuation for "enforced" errors. deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (BuiltinCont e step b i) -instance (NFData b, NFData i) => NFData (CapCont e step b i) -instance (NFData b, NFData i) => NFData (CondCont e step b i) -instance (NFData b, NFData i) => NFData (Cont e step b i) +instance (NFData b, NFData i) => NFData (BuiltinCont e b i) +instance (NFData b, NFData i) => NFData (CapCont e b i) +instance (NFData b, NFData i) => NFData (CondCont e b i) +instance (NFData b, NFData i) => NFData (Cont e b i) -- | An enumerable set of frame types, for our gas model data ContType @@ -564,24 +561,24 @@ data EvalCapType | TestCapEval deriving (Show, Eq, Enum, Bounded) -data CEKErrorHandler (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) +data CEKErrorHandler (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) = CEKNoHandler - | CEKHandler (CEKEnv e step b i) (EvalTerm b i) (Cont e step b i) (ErrorState i) (CEKErrorHandler e step b i) - | CEKEnforceOne (CEKEnv e step b i) i (EvalTerm b i) [EvalTerm b i] (Cont e step b i) (ErrorState i) (CEKErrorHandler e step b i) + | CEKHandler (CEKEnv e b i) (EvalTerm b i) (Cont e b i) (ErrorState i) (CEKErrorHandler e b i) + | CEKEnforceOne (CEKEnv e b i) i (EvalTerm b i) [EvalTerm b i] (Cont e b i) (ErrorState i) (CEKErrorHandler e b i) deriving (Show, Generic) -instance (NFData b, NFData i) => NFData (CEKErrorHandler e step b i) +instance (NFData b, NFData i) => NFData (CEKErrorHandler e b i) -data CEKStepKind - = CEKSmallStep - | CEKBigStep - deriving (Eq, Show) +-- data CEKStepKind +-- = CEKSmallStep +-- | CEKBigStep +-- deriving (Eq, Show) -type family CEKEvalResult (e :: RuntimeMode) (step :: CEKStepKind) (b :: K.Type) (i :: K.Type) where - CEKEvalResult e CEKBigStep b i = EvalResult e CEKBigStep b i - CEKEvalResult e CEKSmallStep b i = CEKReturn e b i +-- type family CEKEvalResult (e :: RuntimeMode) (b :: K.Type) (i :: K.Type) where +-- CEKEvalResult e CEKBigStep b i = EvalResult e CEKBigStep b i +-- CEKEvalResult e CEKSmallStep b i = CEKReturn e b i -instance (Show i, Show b) => Show (NativeFn e step b i) where +instance (Show i, Show b) => Show (NativeFn e b i) where show (NativeFn b _ _ arity _) = unwords ["(NativeFn" , show b @@ -590,7 +587,7 @@ instance (Show i, Show b) => Show (NativeFn e step b i) where , ")" ] -instance (Show i, Show b) => Show (PartialNativeFn e step b i) where +instance (Show i, Show b) => Show (PartialNativeFn e b i) where show (PartialNativeFn b _ _ arity _ _) = unwords ["(NativeFn" , show b @@ -599,10 +596,10 @@ instance (Show i, Show b) => Show (PartialNativeFn e step b i) where , ")" ] -instance (Pretty b, Show i, Show b) => Pretty (NativeFn e step b i) where +instance (Pretty b, Show i, Show b) => Pretty (NativeFn e b i) where pretty = pretty . show -instance (Show i, Show b, Pretty b) => Pretty (CEKValue e step b i) where +instance (Show i, Show b, Pretty b) => Pretty (CEKValue e b i) where pretty = \case VPactValue pv -> pretty pv VTable tv -> "table" <> P.braces (pretty (_tvName tv)) @@ -613,9 +610,9 @@ makeLenses ''CEKEnv type Eval = EvalM ExecRuntime CoreBuiltin type CoreTerm a = EvalTerm CoreBuiltin a -type CoreCEKCont = Cont ExecRuntime CEKBigStep CoreBuiltin -type CoreCEKHandler = CEKErrorHandler ExecRuntime CEKBigStep CoreBuiltin -type CoreCEKEnv = CEKEnv ExecRuntime CEKBigStep CoreBuiltin -type CoreBuiltinEnv a = BuiltinEnv ExecRuntime CEKBigStep CoreBuiltin a -type CoreCEKValue = CEKValue ExecRuntime CEKBigStep CoreBuiltin -type CoreEvalResult = EvalResult ExecRuntime CEKBigStep CoreBuiltin +type CoreCEKCont = Cont ExecRuntime CoreBuiltin +type CoreCEKHandler = CEKErrorHandler ExecRuntime CoreBuiltin +type CoreCEKEnv = CEKEnv ExecRuntime CoreBuiltin +type CoreBuiltinEnv a = BuiltinEnv ExecRuntime CoreBuiltin a +type CoreCEKValue = CEKValue ExecRuntime CoreBuiltin +type CoreEvalResult = EvalResult ExecRuntime CoreBuiltin diff --git a/pact/Pact/Core/IR/Eval/CEK/Utils.hs b/pact/Pact/Core/IR/Eval/CEK/Utils.hs index 2731330c1..29445e926 100644 --- a/pact/Pact/Core/IR/Eval/CEK/Utils.hs +++ b/pact/Pact/Core/IR/Eval/CEK/Utils.hs @@ -27,9 +27,9 @@ mkBuiltinFn :: (IsBuiltin b) => i -> b - -> CEKEnv e step b i - -> NativeFunction e step b i - -> NativeFn e step b i + -> CEKEnv e b i + -> NativeFunction e b i + -> NativeFn e b i mkBuiltinFn i b env fn = NativeFn b env fn (builtinArity b) i {-# INLINE mkBuiltinFn #-} @@ -38,12 +38,12 @@ argsError :: IsBuiltin b => i -> b - -> [CEKValue e step b i] + -> [CEKValue e b i] -> EvalM e b i a argsError info b args = throwExecutionError info (NativeArgumentsError (builtinName b) (toArgTypeError <$> args)) -toArgTypeError :: CEKValue e step b i -> ArgTypeError +toArgTypeError :: CEKValue e b i -> ArgTypeError toArgTypeError = \case VPactValue pv -> case pv of PLiteral l -> ATEPrim (literalPrim l) @@ -69,7 +69,7 @@ tryNodeGas :: MilliGas tryNodeGas = (MilliGas 100) -readOnlyEnv :: CEKEnv e step b i -> CEKEnv e step b i +readOnlyEnv :: CEKEnv e b i -> CEKEnv e b i readOnlyEnv e | view (cePactDb . pdbPurity) e == PSysOnly = e | otherwise = @@ -87,7 +87,7 @@ readOnlyEnv e } in set cePactDb newPactdb e -sysOnlyEnv :: forall e step b i. CEKEnv e step b i -> CEKEnv e step b i +sysOnlyEnv :: forall e b i. CEKEnv e b i -> CEKEnv e b i sysOnlyEnv e | view (cePactDb . pdbPurity) e == PSysOnly = e | otherwise = @@ -111,12 +111,12 @@ sysOnlyEnv e _ -> _pdbRead pdb dom k -envFromPurity :: Purity -> CEKEnv e step b i -> CEKEnv e step b i +envFromPurity :: Purity -> CEKEnv e b i -> CEKEnv e b i envFromPurity PImpure = id envFromPurity PReadOnly = readOnlyEnv envFromPurity PSysOnly = sysOnlyEnv -enforcePactValue :: i -> CEKValue e step b i -> EvalM e b i PactValue +enforcePactValue :: i -> CEKValue e b i -> EvalM e b i PactValue enforcePactValue info = \case VPactValue pv -> pure pv _ -> throwExecutionError info ExpectedPactValue diff --git a/pact/Pact/Core/IR/Eval/CoreBuiltin.hs b/pact/Pact/Core/IR/Eval/CoreBuiltin.hs index 03ee8b1e5..4e4d2bf6a 100644 --- a/pact/Pact/Core/IR/Eval/CoreBuiltin.hs +++ b/pact/Pact/Core/IR/Eval/CoreBuiltin.hs @@ -87,7 +87,7 @@ import qualified Data.Binary.Put as Bin ---------------------------------------------------------------------- -- Our builtin definitions start here ---------------------------------------------------------------------- -unaryIntFn :: (CEKEval e step b i, IsBuiltin b) => (Integer -> Integer) -> NativeFunction e step b i +unaryIntFn :: (IsBuiltin b) => (Integer -> Integer) -> NativeFunction e b i unaryIntFn op info b cont handler _env = \case [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (op i))) @@ -95,9 +95,9 @@ unaryIntFn op info b cont handler _env = \case {-# INLINE unaryIntFn #-} binaryIntFn - :: (CEKEval e step b i, IsBuiltin b) + :: (IsBuiltin b) => (Integer -> Integer -> Integer) - -> NativeFunction e step b i + -> NativeFunction e b i binaryIntFn op info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> returnCEKValue cont handler (VLiteral (LInteger (op i i'))) args -> argsError info b args @@ -117,7 +117,7 @@ binaryIntFn op info b cont handler _env = \case -- GT -> toRational n * multiplier -- `roundTo'` thus has the same asymptotic complexity as multiplication/division. Thus, worst case, we can upperbound it via -- division -roundingFn :: (CEKEval e step b i, IsBuiltin b) => (Rational -> Integer) -> NativeFunction e step b i +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)))) @@ -130,12 +130,9 @@ roundingFn op info b cont handler _env = \case -- Arithmetic Ops ------------------------------ {-# SPECIALIZE rawAdd - :: NativeFunction ExecRuntime CEKBigStep CoreBuiltin i + :: NativeFunction ExecRuntime CoreBuiltin i #-} -{-# SPECIALIZE rawAdd - :: NativeFunction ExecRuntime CEKSmallStep CoreBuiltin i - #-} -rawAdd :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawAdd :: (IsBuiltin b) => NativeFunction e b i rawAdd info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> do chargeGasArgs info (GIntegerOpCost PrimOpAdd i i') @@ -164,7 +161,7 @@ rawAdd info b cont handler _env = \case chargeGasArgs info (GIntegerOpCost PrimOpAdd (decimalMantissa i) (decimalMantissa i')) returnCEKValue cont handler (VLiteral (LDecimal (i + i'))) -rawSub :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawSub :: (IsBuiltin b) => NativeFunction e b i rawSub info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> do chargeGasArgs info (GIntegerOpCost PrimOpSub i i') @@ -184,7 +181,7 @@ rawSub info b cont handler _env = \case -rawMul :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawMul :: (IsBuiltin b) => NativeFunction e b i rawMul info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> do chargeGasArgs info (GIntegerOpCost PrimOpMul i i') @@ -203,7 +200,7 @@ rawMul info b cont handler _env = \case chargeGasArgs info (GIntegerOpCost PrimOpMul (decimalMantissa i) (decimalMantissa i')) returnCEKValue cont handler (VLiteral (LDecimal (i * i'))) -rawPow :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawPow :: (IsBuiltin b) => NativeFunction e b i rawPow info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> do chargeGasArgs info $ GIntegerOpCost PrimOpPow i i' @@ -223,7 +220,7 @@ rawPow info b cont handler _env = \case guardNanOrInf info result returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) -rawLogBase :: forall e step b i. (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawLogBase :: forall e b i. (IsBuiltin b) => NativeFunction e b i rawLogBase info b cont handler _env = \case [VLiteral (LInteger base), VLiteral (LInteger n)] -> do checkArgs base n @@ -251,7 +248,7 @@ rawLogBase info b cont handler _env = \case when (arg <= 0) $ throwExecutionError info (ArithmeticException "Non-positive log argument") -rawDiv :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawDiv :: (IsBuiltin b) => NativeFunction e b i rawDiv info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> do when (i' == 0) $ throwExecutionError info (ArithmeticException "div by zero") @@ -273,7 +270,7 @@ rawDiv info b cont handler _env = \case returnCEKValue cont handler (VLiteral (LDecimal (i / i'))) -rawNegate :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawNegate :: (IsBuiltin b) => NativeFunction e b i rawNegate info b cont handler _env = \case [VLiteral (LInteger i)] -> returnCEKValue cont handler (VLiteral (LInteger (negate i))) @@ -281,36 +278,36 @@ rawNegate info b cont handler _env = \case returnCEKValue cont handler (VLiteral (LDecimal (negate i))) args -> argsError info b args -rawEq :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawEq :: (IsBuiltin b) => NativeFunction e b i rawEq info b cont handler _env = \case [VPactValue pv, VPactValue pv'] -> do isEq <- valEqGassed info pv pv' returnCEKValue cont handler (VBool isEq) args -> argsError info b args -modInt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +modInt :: (IsBuiltin b) => NativeFunction e b i modInt = binaryIntFn mod -rawNeq :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawNeq :: (IsBuiltin b) => NativeFunction e b i rawNeq info b cont handler _env = \case [VPactValue pv, VPactValue pv'] -> do isEq <- valEqGassed info pv pv' returnCEKValue cont handler (VBool $ not isEq) args -> argsError info b args -rawGt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawGt :: (IsBuiltin b) => NativeFunction e b i rawGt = defCmp (== GT) -rawLt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawLt :: (IsBuiltin b) => NativeFunction e b i rawLt = defCmp (== LT) -rawGeq :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawGeq :: (IsBuiltin b) => NativeFunction e b i rawGeq = defCmp (`elem` [GT, EQ]) -rawLeq :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawLeq :: (IsBuiltin b) => NativeFunction e b i rawLeq = defCmp (`elem` [LT, EQ]) -defCmp :: (CEKEval e step b i, IsBuiltin b) => (Ordering -> Bool) -> NativeFunction e step b i +defCmp :: (IsBuiltin b) => (Ordering -> Bool) -> NativeFunction e b i defCmp predicate info b cont handler _env = \case args@[VLiteral lit1, VLiteral lit2] -> litCmpGassed info lit1 lit2 >>= \case Just ordering -> returnCEKValue cont handler $ VBool $ predicate ordering @@ -320,26 +317,26 @@ defCmp predicate info b cont handler _env = \case args -> argsError info b args {-# INLINE defCmp #-} -bitAndInt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +bitAndInt :: (IsBuiltin b) => NativeFunction e b i bitAndInt = binaryIntFn (.&.) -bitOrInt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +bitOrInt :: (IsBuiltin b) => NativeFunction e b i bitOrInt = binaryIntFn (.|.) -bitComplementInt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +bitComplementInt :: (IsBuiltin b) => NativeFunction e b i bitComplementInt = unaryIntFn complement -bitXorInt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +bitXorInt :: (IsBuiltin b) => NativeFunction e b i bitXorInt = binaryIntFn xor -bitShiftInt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +bitShiftInt :: (IsBuiltin b) => NativeFunction e b i bitShiftInt info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LInteger i')] -> do chargeGasArgs info $ GIntegerOpCost PrimOpShift i i' returnCEKValue cont handler (VLiteral (LInteger (i `shift` fromIntegral i'))) args -> argsError info b args -rawAbs :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawAbs :: (IsBuiltin b) => NativeFunction e b i rawAbs info b cont handler _env = \case [VLiteral (LInteger i)] -> do returnCEKValue cont handler (VLiteral (LInteger (abs i))) @@ -347,7 +344,7 @@ rawAbs info b cont handler _env = \case returnCEKValue cont handler (VLiteral (LDecimal (abs e))) args -> argsError info b args -rawExp :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawExp :: (IsBuiltin b) => NativeFunction e b i rawExp info b cont handler _env = \case [VLiteral (LInteger i)] -> do let result = Musl.trans_exp (fromIntegral i) @@ -359,7 +356,7 @@ rawExp info b cont handler _env = \case returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) args -> argsError info b args -rawLn :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawLn :: (IsBuiltin b) => NativeFunction e b i rawLn info b cont handler _env = \case [VLiteral (LInteger i)] -> do let result = Musl.trans_ln (fromIntegral i) @@ -371,7 +368,7 @@ rawLn info b cont handler _env = \case returnCEKValue cont handler (VLiteral (LDecimal (f2Dec result))) args -> argsError info b args -rawSqrt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawSqrt :: (IsBuiltin b) => NativeFunction e b i rawSqrt info b cont handler _env = \case [VLiteral (LInteger i)] -> do when (i < 0) $ throwExecutionError info (ArithmeticException "Square root must be non-negative") @@ -387,7 +384,7 @@ rawSqrt info b cont handler _env = \case -rawShow :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawShow :: (IsBuiltin b) => NativeFunction e b i rawShow info b cont handler _env = \case [VPactValue pv] -> do str <- renderPactValue info pv @@ -395,7 +392,7 @@ rawShow info b cont handler _env = \case args -> argsError info b args -- Todo: Gas here is complicated, greg worked on this previously -rawContains :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawContains :: (IsBuiltin b) => NativeFunction e b i rawContains info b cont handler _env = \case [VString f, VObject o] -> do chargeGasArgs info $ GSearch $ FieldSearch (M.size o) @@ -410,7 +407,7 @@ rawContains info b cont handler _env = \case returnCEKValue cont handler (VBool res) args -> argsError info b args -rawSort :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawSort :: (IsBuiltin b) => NativeFunction e b i rawSort info b cont handler _env = \case [VList vli] | V.null vli -> returnCEKValue cont handler (VList mempty) @@ -422,7 +419,7 @@ rawSort info b cont handler _env = \case returnCEKValue cont handler (VList vli') args -> argsError info b args -coreRemove :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreRemove :: (IsBuiltin b) => NativeFunction e b i coreRemove info b cont handler _env = \case [VString s, VObject o] -> do chargeGasArgs info $ GObjOp $ ObjOpRemove s (M.size o) @@ -439,7 +436,7 @@ asObject info b = \case PObject o -> pure o arg -> argsError info b [VPactValue arg] -rawSortObject :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawSortObject :: (IsBuiltin b) => NativeFunction e b i rawSortObject info b cont handler _env = \case [VList fields, VList objs] | V.null fields -> returnCEKValue cont handler (VList objs) @@ -477,19 +474,19 @@ dec2F = fromRational . toRational f2Dec :: Double -> Decimal f2Dec = fromRational . toRational -roundDec :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +roundDec :: (IsBuiltin b) => NativeFunction e b i roundDec = roundingFn round -floorDec :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +floorDec :: (IsBuiltin b) => NativeFunction e b i floorDec = roundingFn floor -ceilingDec :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +ceilingDec :: (IsBuiltin b) => NativeFunction e b i ceilingDec = roundingFn ceiling --------------------------- -- bool ops --------------------------- -notBool :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +notBool :: (IsBuiltin b) => NativeFunction e b i notBool info b cont handler _env = \case [VLiteral (LBool i)] -> returnCEKValue cont handler (VLiteral (LBool (not i))) args -> argsError info b args @@ -509,7 +506,7 @@ notBool info b cont handler _env = \case -- That's because `i` may contain values larger than `Int`, which is the type `length` typically returns. -- The sum `i + length t` may overflow `Int`, so it's converted to `Integer`, and the result of the `clamp` is always -- below `maxBound :: Int`, so it can be safely casted back without overflow. -rawTake :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawTake :: (IsBuiltin b) => NativeFunction e b i rawTake info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LString t)] | i >= 0 -> do @@ -539,7 +536,7 @@ rawTake info b cont handler _env = \case returnCEKValue cont handler $ VObject $ M.restrictKeys o (S.fromList strings) args -> argsError info b args -rawDrop :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawDrop :: (IsBuiltin b) => NativeFunction e b i rawDrop info b cont handler _env = \case [VLiteral (LInteger i), VLiteral (LString t)] | i >= 0 -> do @@ -564,7 +561,7 @@ rawDrop info b cont handler _env = \case returnCEKValue cont handler $ VObject $ M.withoutKeys o (S.fromList strings) args -> argsError info b args -rawLength :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawLength :: (IsBuiltin b) => NativeFunction e b i rawLength info b cont handler _env = \case [VString t] -> do chargeGasArgs info $ GStrOp $ StrOpLength $ T.length t @@ -574,7 +571,7 @@ rawLength info b cont handler _env = \case returnCEKValue cont handler $ VInteger $ fromIntegral (M.size o) args -> argsError info b args -rawReverse :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +rawReverse :: (IsBuiltin b) => NativeFunction e b i rawReverse info b cont handler _env = \case [VList li] -> do chargeGasArgs info (GConcat (ListConcat (GasListLength (V.length li)))) @@ -584,7 +581,7 @@ rawReverse info b cont handler _env = \case returnCEKValue cont handler (VLiteral (LString (T.reverse t))) args -> argsError info b args -coreConcat :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreConcat :: (IsBuiltin b) => NativeFunction e b i coreConcat info b cont handler _env = \case [VList li] | V.null li -> returnCEKValue cont handler (VString mempty) @@ -595,7 +592,7 @@ coreConcat info b cont handler _env = \case returnCEKValue cont handler (VString (T.concat (V.toList li'))) args -> argsError info b args -strToList :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +strToList :: (IsBuiltin b) => NativeFunction e b i strToList info b cont handler _env = \case [VLiteral (LString s)] -> do chargeGasArgs info $ GStrOp $ StrOpExplode $ T.length s @@ -604,7 +601,7 @@ strToList info b cont handler _env = \case args -> argsError info b args -zipList :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +zipList :: (IsBuiltin b) => NativeFunction e b i zipList info b cont handler _env = \case [VClosure clo, VList l, VList r] -> case (V.toList l, V.toList r) of @@ -615,7 +612,7 @@ zipList info b cont handler _env = \case (_, _) -> returnCEKValue cont handler (VList mempty) args -> argsError info b args -coreMap :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreMap :: (IsBuiltin b) => NativeFunction e b i coreMap info b cont handler env = \case [VClosure clo, VList li] -> case V.toList li of x:xs -> do @@ -625,7 +622,7 @@ coreMap info b cont handler env = \case [] -> returnCEKValue cont handler (VList mempty) args -> argsError info b args -coreFilter :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreFilter :: (IsBuiltin b) => NativeFunction e b i coreFilter info b cont handler _env = \case [VClosure clo, VList li] -> case V.toList li of x:xs -> do @@ -635,7 +632,7 @@ coreFilter info b cont handler _env = \case [] -> returnCEKValue cont handler (VList mempty) args -> argsError info b args -coreFold :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreFold :: (IsBuiltin b) => NativeFunction e b i coreFold info b cont handler _env = \case [VClosure clo, VPactValue initElem, VList li] -> case V.toList li of @@ -646,7 +643,7 @@ coreFold info b cont handler _env = \case [] -> returnCEKValue cont handler (VPactValue initElem) args -> argsError info b args -coreEnumerate :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreEnumerate :: (IsBuiltin b) => NativeFunction e b i coreEnumerate info b cont handler _env = \case [VLiteral (LInteger from), VLiteral (LInteger to)] -> do v <- createEnumerateList info from to (if from > to then -1 else 1) @@ -654,14 +651,14 @@ coreEnumerate info b cont handler _env = \case args -> argsError info b args -coreEnumerateStepN :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreEnumerateStepN :: (IsBuiltin b) => NativeFunction e b i coreEnumerateStepN info b cont handler _env = \case [VLiteral (LInteger from), VLiteral (LInteger to), VLiteral (LInteger inc)] -> do v <- createEnumerateList info from to inc returnCEKValue cont handler (VList (PLiteral . LInteger <$> v)) args -> argsError info b args -makeList :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +makeList :: (IsBuiltin b) => NativeFunction e b i makeList info b cont handler _env = \case [VLiteral (LInteger i), VPactValue v] -> do vSize <- sizeOf info SizeOfV0 v @@ -669,7 +666,7 @@ makeList info b cont handler _env = \case returnCEKValue cont handler (VList (V.fromList (replicate (fromIntegral i) v))) args -> argsError info b args -coreAccess :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreAccess :: (IsBuiltin b) => NativeFunction e b i coreAccess info b cont handler _env = \case [VLiteral (LInteger i), VList vec] -> case vec V.!? fromIntegral i of @@ -684,7 +681,7 @@ coreAccess info b cont handler _env = \case throwExecutionError info (ObjectIsMissingField (Field field) (ObjectData o)) args -> argsError info b args -coreIsCharset :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreIsCharset :: (IsBuiltin b) => NativeFunction e b i coreIsCharset info b cont handler _env = \case [VLiteral (LInteger i), VString s] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length s @@ -695,7 +692,7 @@ coreIsCharset info b cont handler _env = \case throwNativeExecutionError info b "Unsupported character set" args -> argsError info b args -coreYield :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreYield :: (IsBuiltin b) => NativeFunction e b i coreYield info b cont handler _env = \case [VObject o] -> go o Nothing [VObject o, VString cid] -> go o (Just (ChainId cid)) @@ -718,7 +715,7 @@ coreYield info b cont handler _env = \case provenanceOf tid = Provenance tid . _mHash <$> getCallingModule info -corePactId :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +corePactId :: (IsBuiltin b) => NativeFunction e b i corePactId info b cont handler _env = \case [] -> use esDefPactExec >>= \case Just dpe -> returnCEKValue cont handler (VString (_defPactId (_peDefPactId dpe))) @@ -738,7 +735,7 @@ enforceYield info y = case _yProvenance y of let p' = Provenance cid (_mHash m):map (Provenance cid) (toList $ _mBlessed m) unless (p `elem` p') $ throwExecutionError info (YieldProvenanceDoesNotMatch p p') -coreResume :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreResume :: (IsBuiltin b) => NativeFunction e b i coreResume info b cont handler _env = \case [VClosure clo] -> do mps <- viewEvalEnv eeDefPactStep @@ -769,7 +766,7 @@ enforceTopLevelOnly info b = do -- Other Core forms ----------------------------------- -coreB64Encode :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreB64Encode :: (IsBuiltin b) => NativeFunction e b i coreB64Encode info b cont handler _env = \case [VLiteral (LString l)] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length l @@ -777,7 +774,7 @@ coreB64Encode info b cont handler _env = \case args -> argsError info b args -coreB64Decode :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreB64Decode :: (IsBuiltin b) => NativeFunction e b i coreB64Decode info b cont handler _env = \case [VLiteral (LString s)] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length s @@ -788,7 +785,7 @@ coreB64Decode info b cont handler _env = \case -- | The implementation of `enforce-guard` native. -coreEnforceGuard :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreEnforceGuard :: (IsBuiltin b) => NativeFunction e b i coreEnforceGuard info b cont handler env = \case [VGuard g] -> enforceGuard info cont handler env g [VString s] -> do @@ -799,7 +796,7 @@ coreEnforceGuard info b cont handler env = \case Right ksn -> isKeysetNameInSigs info cont handler env ksn args -> argsError info b args -keysetRefGuard :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +keysetRefGuard :: (IsBuiltin b) => NativeFunction e b i keysetRefGuard info b cont handler env = \case [VString g] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length g @@ -813,7 +810,7 @@ keysetRefGuard info b cont handler env = \case Just _ -> returnCEKValue cont handler (VGuard (GKeySetRef ksn)) args -> argsError info b args -coreTypeOf :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreTypeOf :: (IsBuiltin b) => NativeFunction e b i coreTypeOf info b cont handler _env = \case [v] -> case v of VPactValue pv -> @@ -822,18 +819,18 @@ coreTypeOf info b cont handler _env = \case VTable tv -> returnCEKValue cont handler $ VString (renderType (TyTable (_tvSchema tv))) args -> argsError info b args -coreDec :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreDec :: (IsBuiltin b) => NativeFunction e b i coreDec info b cont handler _env = \case [VInteger i] -> returnCEKValue cont handler $ VDecimal $ Decimal 0 i args -> argsError info b args throwReadError - :: (CEKEval e step b i, IsBuiltin b) + :: (IsBuiltin b) => i - -> Cont e step b i - -> CEKErrorHandler e step b i + -> Cont e b i + -> CEKErrorHandler e b i -> b - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) throwReadError info cont handler b = returnCEKError info cont handler $ EnvReadFunctionFailure (builtinName b) @@ -868,7 +865,7 @@ can happen: - We may see a PDecimal, in which case we round - We may see a PInteger, which we read as-is. -} -coreReadInteger :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreReadInteger :: (IsBuiltin b) => NativeFunction e b i coreReadInteger info b cont handler _env = \case [VString s] -> do viewEvalEnv eeMsgBody >>= \case @@ -890,7 +887,7 @@ coreReadInteger info b cont handler _env = \case _ -> throwReadError info cont handler b args -> argsError info b args -coreReadMsg :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreReadMsg :: (IsBuiltin b) => NativeFunction e b i coreReadMsg info b cont handler _env = \case [VString s] -> do viewEvalEnv eeMsgBody >>= \case @@ -921,7 +918,7 @@ instance A.FromJSON ParsedDecimal where So the string parsing case accepts both the integer, and decimal output -} -coreReadDecimal :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreReadDecimal :: (IsBuiltin b) => NativeFunction e b i coreReadDecimal info b cont handler _env = \case [VString s] -> do viewEvalEnv eeMsgBody >>= \case @@ -942,7 +939,7 @@ coreReadDecimal info b cont handler _env = \case args -> argsError info b args -coreReadString :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreReadString :: (IsBuiltin b) => NativeFunction e b i coreReadString info b cont handler _env = \case [VString s] -> do viewEvalEnv eeMsgBody >>= \case @@ -957,7 +954,7 @@ coreReadString info b cont handler _env = \case -coreReadKeyset :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreReadKeyset :: (IsBuiltin b) => NativeFunction e b i coreReadKeyset info b cont handler _env = \case [VString ksn] -> readKeyset' info ksn >>= \case @@ -971,7 +968,7 @@ coreReadKeyset info b cont handler _env = \case args -> argsError info b args -coreBind :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreBind :: (IsBuiltin b) => NativeFunction e b i coreBind info b cont handler _env = \case [v@VObject{}, VClosure clo] -> applyLam clo [v] cont handler @@ -982,7 +979,7 @@ coreBind info b cont handler _env = \case -- Db functions -------------------------------------------------- -createTable :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +createTable :: (IsBuiltin b) => NativeFunction e b i createTable info b cont handler env = \case [VTable tv] -> do enforceTopLevelOnly info b @@ -990,7 +987,7 @@ createTable info b cont handler env = \case guardTable info cont' handler env tv GtCreateTable args -> argsError info b args -dbSelect :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbSelect :: (IsBuiltin b) => NativeFunction e b i dbSelect info b cont handler env = \case [VTable tv, VClosure clo] -> do let cont' = BuiltinC env info (PreSelectC tv clo Nothing) cont @@ -1001,21 +998,21 @@ dbSelect info b cont handler env = \case guardTable info cont' handler env tv GtSelect args -> argsError info b args -foldDb :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +foldDb :: (IsBuiltin b) => NativeFunction e b i foldDb info b cont handler env = \case [VTable tv, VClosure queryClo, VClosure consumer] -> do let cont' = BuiltinC env info (PreFoldDbC tv queryClo consumer) cont guardTable info cont' handler env tv GtSelect args -> argsError info b args -dbRead :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbRead :: (IsBuiltin b) => NativeFunction e b i dbRead info b cont handler env = \case [VTable tv, VString k] -> do let cont' = BuiltinC env info (ReadC tv (RowKey k)) cont guardTable info cont' handler env tv GtRead args -> argsError info b args -dbWithRead :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbWithRead :: (IsBuiltin b) => NativeFunction e b i dbWithRead info b cont handler env = \case [VTable tv, VString k, VClosure clo] -> do let cont1 = Fn clo env [] [] cont @@ -1023,7 +1020,7 @@ dbWithRead info b cont handler env = \case guardTable info cont2 handler env tv GtWithRead args -> argsError info b args -dbWithDefaultRead :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbWithDefaultRead :: (IsBuiltin b) => NativeFunction e b i dbWithDefaultRead info b cont handler env = \case [VTable tv, VString k, VObject defaultObj, VClosure clo] -> do let cont' = BuiltinC env info (WithDefaultReadC tv (RowKey k) (ObjectData defaultObj) clo) cont @@ -1031,23 +1028,23 @@ dbWithDefaultRead info b cont handler env = \case args -> argsError info b args -- | Todo: schema checking here? Or only on writes? -dbWrite :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbWrite :: (IsBuiltin b) => NativeFunction e b i dbWrite = write' Write -dbInsert :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbInsert :: (IsBuiltin b) => NativeFunction e b i dbInsert = write' Insert -write' :: (CEKEval e step b i, IsBuiltin b) => WriteType -> NativeFunction e step b i +write' :: (IsBuiltin b) => WriteType -> NativeFunction e b i write' wt info b cont handler env = \case [VTable tv, VString key, VObject o] -> do let cont' = BuiltinC env info (WriteC tv wt (RowKey key) (ObjectData o)) cont guardTable info cont' handler env tv GtWrite args -> argsError info b args -dbUpdate :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbUpdate :: (IsBuiltin b) => NativeFunction e b i dbUpdate = write' Update -dbKeys :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbKeys :: (IsBuiltin b) => NativeFunction e b i dbKeys info b cont handler env = \case [VTable tv] -> do let cont' = BuiltinC env info (KeysC tv) cont @@ -1055,14 +1052,14 @@ dbKeys info b cont handler env = \case args -> argsError info b args defineKeySet' - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i - -> CEKEnv e step b i + -> Cont e b i + -> CEKErrorHandler e b i + -> CEKEnv e b i -> T.Text -> KeySet - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) defineKeySet' info cont handler env ksname newKs = do let pdb = view cePactDb env ignoreNamespaces <- not <$> isExecutionFlagSet FlagRequireKeysetNs @@ -1088,7 +1085,7 @@ defineKeySet' info cont handler env ksname newKs = do let cont' = BuiltinC env info (DefineKeysetC ksn newKs) cont enforceGuard info cont' handler env uGuard -defineKeySet :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +defineKeySet :: (IsBuiltin b) => NativeFunction e b i defineKeySet info b cont handler env = \case [VString ksname, VGuard (GKeyset ks)] -> do enforceTopLevelOnly info b @@ -1105,7 +1102,7 @@ defineKeySet info b cont handler env = \case -- Capabilities -------------------------------------------------- -requireCapability :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +requireCapability :: (IsBuiltin b) => NativeFunction e b i requireCapability info b cont handler _env = \case [VCapToken ct] -> do slots <- use $ esCaps . csSlots @@ -1115,14 +1112,14 @@ requireCapability info b cont handler _env = \case args -> argsError info b args -composeCapability :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +composeCapability :: (IsBuiltin b) => NativeFunction e b i composeCapability info b cont handler env = \case [VCapToken ct] -> do enforceStackTopIsDefcap info b composeCap info cont handler env ct args -> argsError info b args -installCapability :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +installCapability :: (IsBuiltin b) => NativeFunction e b i installCapability info b cont handler env = \case [VCapToken ct] -> do enforceNotWithinDefcap info env "install-capability" @@ -1130,7 +1127,7 @@ installCapability info b cont handler env = \case returnCEKValue cont handler (VString "Installed capability") args -> argsError info b args -coreEmitEvent :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreEmitEvent :: (IsBuiltin b) => NativeFunction e b i coreEmitEvent info b cont handler env = \case [VCapToken ct@(CapToken fqn _)] -> do let cont' = BuiltinC env info (EmitEventC ct) cont @@ -1145,7 +1142,7 @@ coreEmitEvent info b cont handler env = \case enforceMeta _ = pure () args -> argsError info b args -createCapGuard :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +createCapGuard :: (IsBuiltin b) => NativeFunction e b i createCapGuard info b cont handler _env = \case [VCapToken ct] -> do let qn = fqnToQualName (_ctName ct) @@ -1153,7 +1150,7 @@ createCapGuard info b cont handler _env = \case returnCEKValue cont handler (VGuard (GCapabilityGuard cg)) args -> argsError info b args -createCapabilityPactGuard :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +createCapabilityPactGuard :: (IsBuiltin b) => NativeFunction e b i createCapabilityPactGuard info b cont handler _env = \case [VCapToken ct] -> do pid <- getDefPactId info @@ -1162,7 +1159,7 @@ createCapabilityPactGuard info b cont handler _env = \case returnCEKValue cont handler (VGuard (GCapabilityGuard cg)) args -> argsError info b args -createModuleGuard :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +createModuleGuard :: (IsBuiltin b) => NativeFunction e b i createModuleGuard info b cont handler _env = \case [VString n] -> findCallingModule >>= \case @@ -1173,7 +1170,7 @@ createModuleGuard info b cont handler _env = \case throwNativeExecutionError info b "create-module-guard: must call within module" args -> argsError info b args -createDefPactGuard :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +createDefPactGuard :: (IsBuiltin b) => NativeFunction e b i createDefPactGuard info b cont handler _env = \case [VString name] -> do dpid <- getDefPactId info @@ -1181,7 +1178,7 @@ createDefPactGuard info b cont handler _env = \case args -> argsError info b args -coreIntToStr :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreIntToStr :: (IsBuiltin b) => NativeFunction e b i coreIntToStr info b cont handler _env = \case [VInteger base, VInteger v] | v < 0 -> @@ -1203,7 +1200,7 @@ coreIntToStr info b cont handler _env = \case throwNativeExecutionError info b "invalid base for base64URL conversion" args -> argsError info b args -coreStrToInt :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreStrToInt :: (IsBuiltin b) => NativeFunction e b i coreStrToInt info b cont handler _env = \case [VString s] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length s @@ -1211,7 +1208,7 @@ coreStrToInt info b cont handler _env = \case doBase info cont handler 10 s args -> argsError info b args -coreStrToIntBase :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreStrToIntBase :: (IsBuiltin b) => NativeFunction e b i coreStrToIntBase info b cont handler _env = \case [VInteger base, VString s] | base == 64 -> do @@ -1240,7 +1237,7 @@ nubByM eq = go xs' <- filterM (fmap not . eq x) xs (x :) <$> go xs' -coreDistinct :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreDistinct :: (IsBuiltin b) => NativeFunction e b i coreDistinct info b cont handler _env = \case [VList s] -> do uniques <- nubByM (valEqGassed info) $ V.toList s @@ -1249,7 +1246,7 @@ coreDistinct info b cont handler _env = \case $ V.fromList uniques args -> argsError info b args -coreFormat :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreFormat :: (IsBuiltin b) => NativeFunction e b i coreFormat info b cont handler _env = \case [VString s, VList es] -> do let parts = T.splitOn "{}" s @@ -1282,13 +1279,13 @@ checkLen info txt = throwExecutionError info $ DecodeError "Invalid input, only up to 512 length supported" doBase - :: (CEKEval e step b i) + :: () => i - -> Cont e step b i - -> CEKErrorHandler e step b i + -> Cont e b i + -> CEKErrorHandler e b i -> Integer -> T.Text - -> EvalM e b i (CEKEvalResult e step b i) + -> EvalM e b i (EvalResult e b i) doBase info cont handler base txt = case baseStrToInt base txt of Left e -> throwExecutionError info (DecodeError e) Right n -> returnCEKValue cont handler (VInteger n) @@ -1325,28 +1322,28 @@ integerToBS v = BS.pack $ reverse $ go v | otherwise = fromIntegral (i .&. 0xff):go (shift i (-8)) -coreAndQ :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreAndQ :: (IsBuiltin b) => NativeFunction e b i coreAndQ info b cont handler env = \case [VClosure l, VClosure r, VPactValue v] -> do let cont' = CondC env info (AndQC r v) cont applyLam l [VPactValue v] cont' handler args -> argsError info b args -coreOrQ :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreOrQ :: (IsBuiltin b) => NativeFunction e b i coreOrQ info b cont handler env = \case [VClosure l, VClosure r, VPactValue v] -> do let cont' = CondC env info (OrQC r v) cont applyLam l [VPactValue v] cont' handler args -> argsError info b args -coreNotQ :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreNotQ :: (IsBuiltin b) => NativeFunction e b i coreNotQ info b cont handler env = \case [VClosure clo, VPactValue v] -> do let cont' = CondC env info NotQC cont applyLam clo [VPactValue v] cont' handler args -> argsError info b args -coreWhere :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreWhere :: (IsBuiltin b) => NativeFunction e b i coreWhere info b cont handler _env = \case [VString field, VClosure app, VObject o] -> do case M.lookup (Field field) o of @@ -1357,7 +1354,7 @@ coreWhere info b cont handler _env = \case throwExecutionError info (ObjectIsMissingField (Field field) (ObjectData o)) args -> argsError info b args -coreHash :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreHash :: (IsBuiltin b) => NativeFunction e b i coreHash = \info b cont handler _env -> \case [VString s] -> returnCEKValue cont handler (go (T.encodeUtf8 s)) @@ -1367,20 +1364,20 @@ coreHash = \info b cont handler _env -> \case where go = VString . hashToText . pactHash -txHash :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +txHash :: (IsBuiltin b) => NativeFunction e b i txHash info b cont handler _env = \case [] -> do h <- viewEvalEnv eeHash returnCEKValue cont handler (VString (hashToText h)) args -> argsError info b args -coreContinue :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreContinue :: (IsBuiltin b) => NativeFunction e b i coreContinue info b cont handler _env = \case [v] -> do returnCEKValue cont handler v args -> argsError info b args -parseTime :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +parseTime :: (IsBuiltin b) => NativeFunction e b i parseTime info b cont handler _env = \case [VString fmt, VString s] -> do chargeGasArgs info $ GStrOp $ StrOpParseTime (T.length fmt) (T.length s) @@ -1390,7 +1387,7 @@ parseTime info b cont handler _env = \case throwNativeExecutionError info b $ "parse-time parse failure" args -> argsError info b args -formatTime :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +formatTime :: (IsBuiltin b) => NativeFunction e b i formatTime info b cont handler _env = \case [VString fmt, VPactValue (PTime t)] -> do chargeGasArgs info $ GStrOp $ StrOpFormatTime $ T.length fmt @@ -1398,7 +1395,7 @@ formatTime info b cont handler _env = \case returnCEKValue cont handler $ VString (T.pack timeString) args -> argsError info b args -time :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +time :: (IsBuiltin b) => NativeFunction e b i time info b cont handler _env = \case [VString s] -> do case PactTime.parseTime "%Y-%m-%dT%H:%M:%SZ" (T.unpack s) of @@ -1407,7 +1404,7 @@ time info b cont handler _env = \case throwNativeExecutionError info b $ "time default format parse failure" args -> argsError info b args -addTime :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +addTime :: (IsBuiltin b) => NativeFunction e b i addTime info b cont handler _env = \case [VPactValue (PTime t), VPactValue (PDecimal seconds)] -> do let newTime = t PactTime..+^ PactTime.fromSeconds seconds @@ -1417,14 +1414,14 @@ addTime info b cont handler _env = \case returnCEKValue cont handler $ VPactValue (PTime newTime) args -> argsError info b args -diffTime :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +diffTime :: (IsBuiltin b) => NativeFunction e b i diffTime info b cont handler _env = \case [VPactValue (PTime x), VPactValue (PTime y)] -> do let secondsDifference = PactTime.toSeconds $ x PactTime..-. y returnCEKValue cont handler $ VPactValue $ PDecimal secondsDifference args -> argsError info b args -minutes :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +minutes :: (IsBuiltin b) => NativeFunction e b i minutes info b cont handler _env = \case [VDecimal x] -> do let seconds = x * 60 @@ -1434,7 +1431,7 @@ minutes info b cont handler _env = \case returnCEKValue cont handler $ VDecimal seconds args -> argsError info b args -hours :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +hours :: (IsBuiltin b) => NativeFunction e b i hours info b cont handler _env = \case [VDecimal x] -> do let seconds = x * 60 * 60 @@ -1444,7 +1441,7 @@ hours info b cont handler _env = \case returnCEKValue cont handler $ VDecimal seconds args -> argsError info b args -days :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +days :: (IsBuiltin b) => NativeFunction e b i days info b cont handler _env = \case [VDecimal x] -> do let seconds = x * 60 * 60 * 24 @@ -1454,7 +1451,7 @@ days info b cont handler _env = \case returnCEKValue cont handler $ VDecimal seconds args -> argsError info b args -describeModule :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +describeModule :: (IsBuiltin b) => NativeFunction e b i describeModule info b cont handler env = \case [VString s] -> case parseModuleName s of Just mname -> do @@ -1477,7 +1474,7 @@ describeModule info b cont handler env = \case throwNativeExecutionError info b $ "invalid module name format" args -> argsError info b args -dbDescribeTable :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbDescribeTable :: (IsBuiltin b) => NativeFunction e b i dbDescribeTable info b cont handler _env = \case [VTable (TableValue name _ schema)] -> do enforceTopLevelOnly info b @@ -1487,7 +1484,7 @@ dbDescribeTable info b cont handler _env = \case ,("type", PString (renderType (TyTable schema)))] args -> argsError info b args -dbDescribeKeySet :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +dbDescribeKeySet :: (IsBuiltin b) => NativeFunction e b i dbDescribeKeySet info b cont handler env = \case [VString s] -> do let pdb = _cePactDb env @@ -1503,28 +1500,28 @@ dbDescribeKeySet info b cont handler env = \case throwNativeExecutionError info b "incorrect keyset name format" args -> argsError info b args -coreCompose :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreCompose :: (IsBuiltin b) => NativeFunction e b i coreCompose info b cont handler env = \case [VClosure clo1, VClosure clo2, v] -> do let cont' = Fn clo2 env [] [] cont applyLam clo1 [v] cont' handler args -> argsError info b args -coreCreatePrincipal :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreCreatePrincipal :: (IsBuiltin b) => NativeFunction e b i coreCreatePrincipal info b cont handler _env = \case [VGuard g] -> do pr <- createPrincipalForGuard info g returnCEKValue cont handler $ VString $ Pr.mkPrincipalIdent pr args -> argsError info b args -coreIsPrincipal :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreIsPrincipal :: (IsBuiltin b) => NativeFunction e b i coreIsPrincipal info b cont handler _env = \case [VString p] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length p returnCEKValue cont handler $ VBool $ isRight $ parseOnly Pr.principalParser p args -> argsError info b args -coreTypeOfPrincipal :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreTypeOfPrincipal :: (IsBuiltin b) => NativeFunction e b i coreTypeOfPrincipal info b cont handler _env = \case [VString p] -> do chargeGasArgs info $ GStrOp $ StrOpParse $ T.length p @@ -1534,7 +1531,7 @@ coreTypeOfPrincipal info b cont handler _env = \case returnCEKValue cont handler $ VString prty args -> argsError info b args -coreValidatePrincipal :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreValidatePrincipal :: (IsBuiltin b) => NativeFunction e b i coreValidatePrincipal info b cont handler _env = \case [VGuard g, VString s] -> do pr' <- createPrincipalForGuard info g @@ -1543,13 +1540,13 @@ coreValidatePrincipal info b cont handler _env = \case args -> argsError info b args -coreCond :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreCond :: (IsBuiltin b) => NativeFunction e b i coreCond info b cont handler _env = \case [VClosure clo] -> applyLam clo [] cont handler args -> argsError info b args -coreIdentity :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreIdentity :: (IsBuiltin b) => NativeFunction e b i coreIdentity info b cont handler _env = \case [VPactValue pv] -> returnCEKValue cont handler $ VPactValue pv args -> argsError info b args @@ -1558,7 +1555,7 @@ coreIdentity info b cont handler _env = \case -------------------------------------------------- -- Namespace functions -------------------------------------------------- -coreNamespace :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreNamespace :: (IsBuiltin b) => NativeFunction e b i coreNamespace info b cont handler env = \case [VString n] -> do enforceTopLevelOnly info b @@ -1580,7 +1577,7 @@ coreNamespace info b cont handler env = \case args -> argsError info b args -coreDefineNamespace :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreDefineNamespace :: (IsBuiltin b) => NativeFunction e b i coreDefineNamespace info b cont handler env = \case [VString n, VGuard usrG, VGuard adminG] -> do enforceTopLevelOnly info b @@ -1624,7 +1621,7 @@ coreDefineNamespace info b cont handler env = \case validSpecialChars = "%#+-_&$@<>=^?*!|/~" -coreDescribeNamespace :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreDescribeNamespace :: (IsBuiltin b) => NativeFunction e b i coreDescribeNamespace info b cont handler _env = \case [VString n] -> do pdb <- viewEvalEnv eePactDb @@ -1643,7 +1640,7 @@ coreDescribeNamespace info b cont handler _env = \case args -> argsError info b args -coreChainData :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreChainData :: (IsBuiltin b) => NativeFunction e b i coreChainData info b cont handler _env = \case [] -> do PublicData publicMeta blockHeight blockTime prevBh <- viewEvalEnv eePublicData @@ -1716,8 +1713,8 @@ fromG2 (Point x y) = ObjectData pts , (Field "y", y')] -zkPairingCheck :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i --- zkPairingCheck :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +zkPairingCheck :: (IsBuiltin b) => NativeFunction e b i +-- zkPairingCheck :: (IsBuiltin b) => NativeFunction e b i zkPairingCheck info b cont handler _env = \case args@[VList p1s, VList p2s] -> do chargeGasArgs info (GAZKArgs (Pairing (max (V.length p1s) (V.length p2s)))) @@ -1729,7 +1726,7 @@ zkPairingCheck info b cont handler _env = \case returnCEKValue cont handler $ VBool $ pairingCheck pairs args -> argsError info b args -zkScalarMult :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +zkScalarMult :: (IsBuiltin b) => NativeFunction e b i zkScalarMult info b cont handler _env = \case args@[VString ptTy, VObject p1, VInteger scalar] -> do let scalar' = scalar `mod` curveOrder @@ -1754,7 +1751,7 @@ zkScalarMult info b cont handler _env = \case curveOrder :: Integer curveOrder = 21888242871839275222246405745257275088548364400416034343698204186575808495617 -zkPointAddition :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +zkPointAddition :: (IsBuiltin b) => NativeFunction e b i zkPointAddition info b cont handler _env = \case args@[VString ptTy, VObject p1, VObject p2] -> do case T.toLower ptTy of @@ -1784,7 +1781,7 @@ zkPointAddition info b cont handler _env = \case -- Poseidon ----------------------------------- -poseidonHash :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +poseidonHash :: (IsBuiltin b) => NativeFunction e b i poseidonHash info b cont handler _env = \case [VList as] | not (V.null as) && length as <= 8, @@ -1795,16 +1792,16 @@ poseidonHash info b cont handler _env = \case #else -zkPairingCheck :: NativeFunction e step b i +zkPairingCheck :: NativeFunction e b i zkPairingCheck info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" -zkScalarMult :: NativeFunction e step b i +zkScalarMult :: NativeFunction e b i zkScalarMult info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" -zkPointAddition :: NativeFunction e step b i +zkPointAddition :: NativeFunction e b i zkPointAddition info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" -poseidonHash :: NativeFunction e step b i +poseidonHash :: NativeFunction e b i poseidonHash info _b _cont _handler _env _args = throwExecutionError info $ EvalError $ "crypto disabled" #endif @@ -1813,7 +1810,7 @@ poseidonHash info _b _cont _handler _env _args = throwExecutionError info $ Eval -- SPV ----------------------------------- -coreVerifySPV :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreVerifySPV :: (IsBuiltin b) => NativeFunction e b i coreVerifySPV info b cont handler _env = \case [VString proofType, VObject o] -> do SPVSupport f _ <- viewEvalEnv eeSPVSupport @@ -1825,7 +1822,7 @@ coreVerifySPV info b cont handler _env = \case ----------------------------------- -- Verifiers ----------------------------------- -coreEnforceVerifier :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreEnforceVerifier :: (IsBuiltin b) => NativeFunction e b i coreEnforceVerifier info b cont handler _env = \case [VString verName] -> do enforceStackTopIsDefcap info b @@ -1842,7 +1839,7 @@ coreEnforceVerifier info b cont handler _env = \case -coreHyperlaneDecodeTokenMessage :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreHyperlaneDecodeTokenMessage :: (IsBuiltin b) => NativeFunction e b i coreHyperlaneDecodeTokenMessage info b cont handler _env = \case [VString s] -> do chargeGasArgs info $ GHyperlaneEncodeDecodeTokenMessage (T.length s) @@ -1858,7 +1855,7 @@ coreHyperlaneDecodeTokenMessage info b cont handler _env = \case Right pv -> returnCEKValue cont handler (VPactValue pv) args -> argsError info b args -coreHyperlaneMessageId :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreHyperlaneMessageId :: (IsBuiltin b) => NativeFunction e b i coreHyperlaneMessageId info b cont handler _env = \case [VObject o] -> case decodeHyperlaneMessageObject o of Left e -> throwExecutionError info $ HyperlaneError e @@ -1868,7 +1865,7 @@ coreHyperlaneMessageId info b cont handler _env = \case returnCEKValue cont handler (VString msgId) args -> argsError info b args -coreHyperlaneEncodeTokenMessage :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreHyperlaneEncodeTokenMessage :: (IsBuiltin b) => NativeFunction e b i coreHyperlaneEncodeTokenMessage info b cont handler _env = \case [VObject o] -> case decodeHyperlaneTokenMessageObject o of Left e -> throwExecutionError info $ HyperlaneError e @@ -1883,27 +1880,20 @@ coreHyperlaneEncodeTokenMessage info b cont handler _env = \case ----------------------------------- -{-# SPECIALIZE coreBuiltinEnv :: BuiltinEnv ExecRuntime CEKBigStep CoreBuiltin i #-} -{-# SPECIALIZE coreBuiltinEnv :: BuiltinEnv ExecRuntime CEKSmallStep CoreBuiltin i #-} coreBuiltinEnv - :: forall e step i. (CEKEval e step CoreBuiltin i) - => BuiltinEnv e step CoreBuiltin i + :: BuiltinEnv e CoreBuiltin i coreBuiltinEnv i b env = mkBuiltinFn i b env (coreBuiltinRuntime b) {-# INLINEABLE coreBuiltinEnv #-} {-# SPECIALIZE coreBuiltinRuntime :: CoreBuiltin - -> NativeFunction ExecRuntime CEKBigStep CoreBuiltin () - #-} -{-# SPECIALIZE coreBuiltinRuntime - :: CoreBuiltin - -> NativeFunction ExecRuntime CEKSmallStep CoreBuiltin i + -> NativeFunction ExecRuntime CoreBuiltin i #-} coreBuiltinRuntime - :: (CEKEval e step b i, IsBuiltin b) + :: (IsBuiltin b) => CoreBuiltin - -> NativeFunction e step b i + -> NativeFunction e b i coreBuiltinRuntime = \case CoreAdd -> rawAdd CoreSub -> rawSub diff --git a/pact/Pact/Core/Repl/Compile.hs b/pact/Pact/Core/Repl/Compile.hs index b2cbddb74..15cb407d2 100644 --- a/pact/Pact/Core/Repl/Compile.hs +++ b/pact/Pact/Core/Repl/Compile.hs @@ -11,11 +11,9 @@ module Pact.Core.Repl.Compile ( ReplCompileValue(..) , interpretReplProgramBigStep - , interpretReplProgramSmallStep , loadFile , interpretReplProgramDirect , interpretEvalBigStep - , interpretEvalSmallStep , interpretEvalDirect , interpretReplProgram , ReplInterpreter @@ -109,11 +107,6 @@ interpretReplProgramBigStep -> ReplM ReplCoreBuiltin [ReplCompileValue] interpretReplProgramBigStep = interpretReplProgram interpretEvalBigStep -interpretReplProgramSmallStep - :: SourceCode - -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) - -> ReplM ReplCoreBuiltin [ReplCompileValue] -interpretReplProgramSmallStep = interpretReplProgram interpretEvalSmallStep interpretReplProgramDirect :: SourceCode @@ -134,27 +127,16 @@ checkReplNativesEnabled = \case throwExecutionError i (EvalError "repl native disallowed in module code. If you want to use this, enable them with (env-enable-repl-natives true)") a -> pure a -interpretEvalSmallStep :: ReplInterpreter -interpretEvalSmallStep = - Interpreter { eval = evalSmallStep, resumePact = evalResumePact, interpretGuard = interpretGuardSmallStep} - where - evalResumePact info pactExec = - CEK.evalResumePact info (replBuiltinEnv @CEK.CEKSmallStep) pactExec - evalSmallStep purity term = - CEK.eval purity (replBuiltinEnv @CEK.CEKSmallStep) term - interpretGuardSmallStep info g = - CEK.interpretGuard info (replBuiltinEnv @CEK.CEKSmallStep) g - interpretEvalBigStep :: ReplInterpreter interpretEvalBigStep = Interpreter { eval = evalBigStep, resumePact = evalResumePact, interpretGuard = interpretGuardBigStep} where evalBigStep purity term = - CEK.eval purity (replBuiltinEnv @CEK.CEKBigStep) term + CEK.eval purity replBuiltinEnv term evalResumePact info pactExec = - CEK.evalResumePact info (replBuiltinEnv @CEK.CEKBigStep) pactExec + CEK.evalResumePact info replBuiltinEnv pactExec interpretGuardBigStep info g = - CEK.interpretGuard info (replBuiltinEnv @CEK.CEKBigStep) g + CEK.interpretGuard info replBuiltinEnv g interpretEvalDirect :: ReplInterpreter interpretEvalDirect = diff --git a/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 19f4fd85a..c16259c22 100644 --- a/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/pact/Pact/Core/Repl/Runtime/ReplBuiltin.hs @@ -52,22 +52,20 @@ import Pact.Core.Repl.Utils import qualified Pact.Time as PactTime import Data.IORef -type ReplCEKEval step = CEKEval 'ReplRuntime step ReplCoreBuiltin SpanInfo - -prettyShowValue :: CEKValue step b i m -> Text +prettyShowValue :: CEKValue b i m -> Text prettyShowValue = \case VPactValue p -> renderText p VTable (TableValue (TableName tn mn) _ _) -> "table{" <> renderModuleName mn <> "_" <> tn <> "}" VClosure _ -> "<#closure>" -corePrint :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +corePrint :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo corePrint info b cont handler _env = \case [v] -> do liftIO $ putStrLn $ T.unpack (prettyShowValue v) returnCEKValue cont handler (VLiteral LUnit) args -> argsError info b args -coreExpect :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +coreExpect :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo coreExpect info b cont handler _env = \case [VLiteral (LString msg), VClosure expected, VClosure provided] -> do es <- get @@ -93,7 +91,7 @@ coreExpect info b cont handler _env = \case replError currSource err args -> argsError info b args -coreExpectThat :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +coreExpectThat :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo coreExpectThat info b cont handler _env = \case [VLiteral (LString msg), VClosure vclo, v] -> do applyLamUnsafe vclo [v] Mt CEKNoHandler >>= \case @@ -104,7 +102,7 @@ coreExpectThat info b cont handler _env = \case ve@VError{} -> returnCEK cont handler ve args -> argsError info b args -coreExpectFailure :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +coreExpectFailure :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo coreExpectFailure info b cont handler _env = \case [VString doc, VClosure vclo] -> do es <- get @@ -135,7 +133,7 @@ coreExpectFailure info b cont handler _env = \case args -> argsError info b args -continuePact :: forall step . ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +continuePact :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo continuePact info b cont handler env = \case [VInteger s] -> go s False Nothing Nothing [VInteger s, VBool r] -> go s r Nothing Nothing @@ -162,12 +160,12 @@ continuePact info b cont handler env = \case let pactStep = DefPactStep (fromInteger step) rollback pid myield esDefPactExec .= Nothing replEvalEnv . eeDefPactStep .== Just pactStep - merr <- tryError $ evalUnsafe @ReplRuntime @step =<< resumePact info Mt CEKNoHandler env Nothing + merr <- tryError $ resumePact info Mt CEKNoHandler env Nothing replEvalEnv . eeDefPactStep .== Nothing v <- liftEither merr returnCEK cont handler v -pactState :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +pactState :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo pactState info b cont handler _env = \case [] -> go False [VBool clear] -> go clear @@ -188,14 +186,14 @@ pactState info b cont handler _env = \case returnCEKValue cont handler (VObject (M.fromList ps)) Nothing -> returnCEKError info cont handler $ UserEnforceError "pact-state: no pact exec in context" -coreplEvalEnvStackFrame :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +coreplEvalEnvStackFrame :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo coreplEvalEnvStackFrame info b cont handler _env = \case [] -> do sfs <- fmap (PString . T.pack . show) <$> use esStack returnCEKValue cont handler $ VList (V.fromList sfs) args -> argsError info b args -envEvents :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envEvents :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envEvents info b cont handler _env = \case [VBool clear] -> do events <- reverse . fmap envToObj <$> use esEvents @@ -211,7 +209,7 @@ envEvents info b cont handler _env = \case , ("module-hash", PString (hashToText (_mhHash mh)))] args -> argsError info b args -envHash :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envHash :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envHash info b cont handler _env = \case [VString s] -> do case decodeBase64UrlUnpadded (T.encodeUtf8 s) of @@ -221,7 +219,7 @@ envHash info b cont handler _env = \case returnCEKValue cont handler $ VString $ "Set tx hash to " <> s args -> argsError info b args -envData :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envData :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envData info b cont handler _env = \case [VPactValue pv] -> do -- to mimic prod, we must roundtrip here @@ -231,7 +229,7 @@ envData info b cont handler _env = \case returnCEKValue cont handler (VString "Setting transaction data") args -> argsError info b args -envChainData :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envChainData :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envChainData info b cont handler _env = \case [VObject cdataObj] -> do pd <- viewEvalEnv eePublicData @@ -261,7 +259,7 @@ envChainData info b cont handler _env = \case _ -> returnCEKError info cont handler $ UserEnforceError $ "envChainData: bad public metadata value for key: " <> _field k args -> argsError info b args -envKeys :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envKeys :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envKeys info b cont handler _env = \case [VList ks] -> do keys <- traverse (asString info b) ks @@ -269,7 +267,7 @@ envKeys info b cont handler _env = \case returnCEKValue cont handler (VString "Setting transaction keys") args -> argsError info b args -envSigs :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envSigs :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envSigs info b cont handler _env = \case [VList ks] -> case traverse keyCapObj ks of @@ -290,7 +288,7 @@ envSigs info b cont handler _env = \case _ -> Nothing args -> argsError info b args -envVerifiers :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envVerifiers :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envVerifiers info b cont handler _env = \case [VList ks] -> case traverse verifCapObj ks of @@ -312,13 +310,13 @@ envVerifiers info b cont handler _env = \case _ -> Nothing args -> argsError info b args -beginTx :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +beginTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo beginTx info b cont handler _env = \case [VString s] -> begin' info (Just s) >>= returnCEK cont handler . renderTx info "Begin Tx" [] -> begin' info Nothing >>= returnCEK cont handler . renderTx info "Begin Tx" args -> argsError info b args -renderTx :: i -> Text -> Maybe (TxId, Maybe Text) -> EvalResult e step b i +renderTx :: i -> Text -> Maybe (TxId, Maybe Text) -> EvalResult e b i renderTx _info start (Just (TxId tid, mt)) = EvalValue $ VString $ start <> " " <> T.pack (show tid) <> maybe mempty (" " <>) mt renderTx info start Nothing = VError [] (UserEnforceError ("tx-function failure " <> start)) info @@ -343,7 +341,7 @@ emptyTxState = do put newEvalState -commitTx :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +commitTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo commitTx info b cont handler _env = \case [] -> do pdb <- useReplState (replEvalEnv . eePactDb) @@ -357,7 +355,7 @@ commitTx info b cont handler _env = \case args -> argsError info b args -rollbackTx :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +rollbackTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo rollbackTx info b cont handler _env = \case [] -> do pdb <- useReplState (replEvalEnv . eePactDb) @@ -370,7 +368,7 @@ rollbackTx info b cont handler _env = \case Nothing -> returnCEK cont handler (renderTx info "Rollback Tx" Nothing) args -> argsError info b args -sigKeyset :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +sigKeyset :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo sigKeyset info b cont handler _env = \case [] -> do sigs <- S.fromList . M.keys <$> viewEvalEnv eeMsgSigs @@ -378,7 +376,7 @@ sigKeyset info b cont handler _env = \case args -> argsError info b args -testCapability :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +testCapability :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo testCapability info b cont handler env = \case [VCapToken origToken] -> do d <- getDefCap info (_ctName origToken) @@ -393,7 +391,7 @@ testCapability info b cont handler env = \case installCap info env origToken False *> evalCap info cont' handler env origToken PopCapInvoke TestCapEval cBody args -> argsError info b args -envExecConfig :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envExecConfig :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envExecConfig info b cont handler _env = \case [VList s] -> do s' <- traverse go (V.toList s) @@ -410,7 +408,7 @@ envExecConfig info b cont handler _env = \case args -> argsError info b args -envNamespacePolicy :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envNamespacePolicy :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envNamespacePolicy info b cont handler _env = \case [VBool allowRoot, VClosure (C clo)] -> do pdb <- viewEvalEnv eePactDb @@ -424,7 +422,7 @@ envNamespacePolicy info b cont handler _env = \case _ -> returnCEKError info cont handler $ UserEnforceError "invalid namespace manager function type" args -> argsError info b args -envGas :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envGas :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envGas info b cont handler _env = \case [] -> do Gas gas <- milliGasToGas <$> getGas @@ -434,7 +432,7 @@ envGas info b cont handler _env = \case returnCEKValue cont handler $ VString $ "Set gas to " <> T.pack (show g) args -> argsError info b args -envMilliGas :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envMilliGas :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envMilliGas info b cont handler _env = \case [] -> do MilliGas gas <- getGas @@ -444,14 +442,14 @@ envMilliGas info b cont handler _env = \case returnCEKValue cont handler $ VString $ "Set milligas to" <> T.pack (show g) args -> argsError info b args -envGasLimit :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envGasLimit :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envGasLimit info b cont handler _env = \case [VInteger g] -> do (replEvalEnv . eeGasEnv . geGasModel . gmGasLimit) .== Just (MilliGasLimit (gasToMilliGas (Gas (fromInteger g)))) returnCEKValue cont handler $ VString $ "Set gas limit to " <> T.pack (show g) args -> argsError info b args -envGasLog :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envGasLog :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envGasLog info b cont handler _env = \case [] -> do (gasLogRef, logsJustEnabled) <- viewEvalEnv (eeGasEnv . geGasLog) >>= \case @@ -471,7 +469,7 @@ envGasLog info b cont handler _env = \case returnCEKValue cont handler (VList $ V.fromList (totalLine:logLines)) args -> argsError info b args -envEnableReplNatives :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envEnableReplNatives :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envEnableReplNatives info b cont handler _env = \case [VBool enabled] -> do let s = if enabled then "enabled" else "disabled" @@ -479,7 +477,7 @@ envEnableReplNatives info b cont handler _env = \case returnCEKValue cont handler $ VString $ "repl natives " <> s args -> argsError info b args -envGasModel :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envGasModel :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envGasModel info b cont handler _env = \case [] -> do gm <- viewEvalEnv (eeGasEnv . geGasModel) @@ -496,7 +494,7 @@ envGasModel info b cont handler _env = \case args -> argsError info b args -envModuleAdmin :: ReplCEKEval step => NativeFunction 'ReplRuntime step ReplCoreBuiltin SpanInfo +envModuleAdmin :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo envModuleAdmin info b cont handler _env = \case [VModRef modRef] -> do let modName = _mrModule modRef @@ -509,7 +507,7 @@ envModuleAdmin info b cont handler _env = \case -- Pact Version ----------------------------------- -coreVersion :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreVersion :: (IsBuiltin b) => NativeFunction e b i coreVersion info b cont handler _env = \case [] -> let v = T.pack (V.showVersion PI.version) @@ -517,7 +515,7 @@ coreVersion info b cont handler _env = \case args -> argsError info b args -coreEnforceVersion :: (CEKEval e step b i, IsBuiltin b) => NativeFunction e step b i +coreEnforceVersion :: (IsBuiltin b) => NativeFunction e b i coreEnforceVersion info b cont handler _env = \case [VString lowerBound] -> do lowerBound' <- mkVersion lowerBound @@ -540,15 +538,13 @@ coreEnforceVersion info b cont handler _env = \case replBuiltinEnv - :: CEKEval 'ReplRuntime step ReplCoreBuiltin SpanInfo - => BuiltinEnv 'ReplRuntime step (ReplBuiltin CoreBuiltin) SpanInfo + :: BuiltinEnv 'ReplRuntime (ReplBuiltin CoreBuiltin) SpanInfo replBuiltinEnv i b env = mkBuiltinFn i b env (replCoreBuiltinRuntime b) replCoreBuiltinRuntime - :: CEKEval 'ReplRuntime step ReplCoreBuiltin SpanInfo - => ReplBuiltin CoreBuiltin - -> NativeFunction 'ReplRuntime step (ReplBuiltin CoreBuiltin) SpanInfo + :: ReplBuiltin CoreBuiltin + -> NativeFunction 'ReplRuntime (ReplBuiltin CoreBuiltin) SpanInfo replCoreBuiltinRuntime = \case RBuiltinWrap cb -> coreBuiltinRuntime cb diff --git a/profile-tx/ProfileTx.hs b/profile-tx/ProfileTx.hs index f2d2942ec..a468f2334 100644 --- a/profile-tx/ProfileTx.hs +++ b/profile-tx/ProfileTx.hs @@ -76,7 +76,7 @@ interpretBigStep = where runTerm purity term = CEK.eval purity eEnv term runGuard info g = CEK.interpretGuard info eEnv g - eEnv = CEK.coreBuiltinEnv @ExecRuntime @CEK.CEKBigStep + eEnv = CEK.coreBuiltinEnv @ExecRuntime evalResumePact info pactExec = CEK.evalResumePact info eEnv pactExec