From b9183f6705820b9d17544dad2ac570fcd752d512 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 14:30:56 +0200 Subject: [PATCH 01/12] elab_conf depends on context --- devtools/get_contracts/get_contracts_alpha.ml | 4 ++-- .../lib_benchmark/test/test_helpers.ml | 2 +- .../lib_benchmarks_proto/cache_benchmarks.ml | 3 ++- .../interpreter_benchmarks.ml | 2 +- .../script_typed_ir_size_benchmarks.ml | 6 +++--- .../translator_benchmarks.ml | 10 +++++----- .../lib_benchmarks_proto/translator_workload.ml | 4 ++-- src/proto_alpha/lib_plugin/RPC.ml | 16 ++++++++-------- src/proto_alpha/lib_protocol/apply.ml | 6 +++--- .../lib_protocol/contract_services.ml | 12 ++++++------ src/proto_alpha/lib_protocol/main.ml | 2 +- .../sc_rollup_management_protocol.ml | 2 +- src/proto_alpha/lib_protocol/script_big_map.ml | 2 +- src/proto_alpha/lib_protocol/script_cache.ml | 2 +- .../lib_protocol/script_interpreter.ml | 6 +++--- .../lib_protocol/script_interpreter_defs.ml | 2 +- .../lib_protocol/script_ir_translator.ml | 9 ++++++--- .../lib_protocol/script_ir_translator_config.ml | 9 ++++++--- .../lib_protocol/script_ir_unparser.ml | 2 +- .../lib_protocol/test/helpers/block.ml | 2 +- .../integration/michelson/test_annotations.ml | 2 +- .../michelson/test_lambda_normalization.ml | 2 +- .../michelson/test_patched_contracts.ml | 2 +- .../test/integration/michelson/test_sapling.ml | 6 ++++-- .../michelson/test_ticket_accounting.ml | 2 +- .../integration/michelson/test_ticket_manager.ml | 2 +- .../michelson/test_ticket_operations_diff.ml | 2 +- .../integration/michelson/test_ticket_scanner.ml | 2 +- .../integration/michelson/test_typechecking.ml | 6 +++--- .../integration/operations/test_sc_rollup.ml | 2 +- src/proto_alpha/lib_protocol/ticket_scanner.ml | 4 ++-- 31 files changed, 72 insertions(+), 63 deletions(-) diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 9c04ef4be89d..2033d329029d 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -135,7 +135,7 @@ module Proto = struct let+ data, updated_ctxt = Lwt.map wrap_tzresult @@ Script_ir_translator.parse_data - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ctxt ~allow_forged ty @@ -187,7 +187,7 @@ module Proto = struct Lwt.map wrap_tzresult @@ Script_ir_translator.parse_code ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~code in parsed_code diff --git a/src/proto_alpha/lib_benchmark/test/test_helpers.ml b/src/proto_alpha/lib_benchmark/test/test_helpers.ml index 0f73aa711b06..bf0a8c36a895 100644 --- a/src/proto_alpha/lib_benchmark/test/test_helpers.ml +++ b/src/proto_alpha/lib_benchmark/test/test_helpers.ml @@ -84,7 +84,7 @@ let typecheck_by_tezos = Protocol.Script_tc_context.data ctxt ~elab_conf: - (Protocol.Script_ir_translator_config.make ~legacy:false ()) + (Protocol.Script_ir_translator_config.make ~legacy:false ctxt) (Micheline.root node) bef >|= Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml index 57c9cd4a52cc..9ce67cb5878d 100644 --- a/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/cache_benchmarks.ml @@ -68,7 +68,8 @@ let dummy_script : Cache.cached_contract = let ex_script, _ = Script_ir_translator.parse_script throwaway_context - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf: + (Script_ir_translator_config.make ~legacy:true throwaway_context) ~allow_forged_in_storage:false script |> assert_ok_lwt diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index ed15db1546c9..42a423883b39 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -1105,7 +1105,7 @@ module Registration_section = struct Script_tc_context.data ctxt ~elab_conf: - (Script_ir_translator_config.make ~legacy:false ()) + (Script_ir_translator_config.make ~legacy:false ctxt) node stack_ty in diff --git a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml index c8a63e224160..b8ad6f254f91 100644 --- a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml @@ -37,7 +37,7 @@ let fv s = Free_variable.of_namespace (ns s) let local_model_name = "script_typed_ir_size" -let strict = Script_ir_translator_config.make ~legacy:false () +let strict ctxt = Script_ir_translator_config.make ~legacy:false ctxt module Size_benchmarks_shared_config = struct include Translator_benchmarks.Config @@ -93,7 +93,7 @@ module Value_size_benchmark : Tezos_benchmark.Benchmark.S = struct Lwt_main.run (Script_ir_translator.parse_data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) ~allow_forged:false ty (Micheline.root node)) @@ -213,7 +213,7 @@ module Kinstr_size_benchmark : Tezos_benchmark.Benchmark.S = struct (Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) node bef) with diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 3244f5dd882e..d15fb2a579d8 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -192,7 +192,7 @@ let bad_code benchmark_name micheline expected_stack_type phase = (* ----------------------------------------------------------------------- *) (* Typechecking data (Micheline data -> typed data) *) -let strict = Script_ir_translator_config.make ~legacy:false () +let strict ctxt = Script_ir_translator_config.make ~legacy:false ctxt module Typechecking_data : Benchmark.S = struct include Config @@ -232,7 +232,7 @@ module Typechecking_data : Benchmark.S = struct Lwt_main.run (Script_ir_translator.parse_data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) ~allow_forged:false ty (Micheline.root node)) @@ -311,7 +311,7 @@ module Unparsing_data : Benchmark.S = struct let*! result = Script_ir_translator.parse_data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) ~allow_forged:false ty (Micheline.root node) @@ -404,7 +404,7 @@ module Typechecking_code : Benchmark.S = struct (Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) (Micheline.root node) bef) in @@ -488,7 +488,7 @@ module Unparsing_code : Benchmark.S = struct Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:strict + ~elab_conf:(strict ctxt) (Micheline.root node) bef in diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml index 09212c347c96..88b50e91adf1 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml @@ -117,7 +117,7 @@ let data_typechecker_workload ctxt t_kind micheline_node ex_ty = (let* res = Script_ir_translator.parse_data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) ~allow_forged:false ty micheline_node @@ -161,7 +161,7 @@ let code_typechecker_workload (ctxt : Protocol.Alpha_context.context) Script_ir_translator.parse_instr Script_tc_context.data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) code stack_ty |> Lwt.map Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 8cfbba3c464c..20b9a1aea174 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -711,7 +711,7 @@ module Scripts = struct in Script_ir_translator.parse_data ctxt - ~elab_conf:(elab_conf ~legacy ()) + ~elab_conf:(elab_conf ~legacy ctxt) ~allow_forged exp_ty (Micheline.root data)) @@ -830,7 +830,7 @@ module Scripts = struct ty_node in let*? (Ex_ty ty) = res in - let elab_conf = elab_conf ~legacy () in + let elab_conf = elab_conf ~legacy ctxt in let* x, ctxt = Script_ir_translator.parse_data ctxt @@ -1621,7 +1621,7 @@ module Scripts = struct | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in - let elab_conf = elab_conf ~legacy () in + let elab_conf = elab_conf ~legacy ctxt in let code = Script.lazy_expr expr in let* ( Ex_code (Code @@ -1684,7 +1684,7 @@ module Scripts = struct let* data, ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged:true typ (Micheline.root expr) @@ -1705,7 +1705,7 @@ module Scripts = struct let* data, ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy ()) + ~elab_conf:(elab_conf ~legacy ctxt) ~allow_forged:true typ (Micheline.root expr) @@ -2054,7 +2054,7 @@ module Contract = struct let* Ex_script (Script {storage; storage_type; _}), ctxt = parse_script ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged_in_storage:true script in @@ -2123,7 +2123,7 @@ module Contract = struct let* Ex_script (Script {storage; storage_type; _}), ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged_in_storage:true script in @@ -2242,7 +2242,7 @@ module Big_map = struct let* value, ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy:true ()) + ~elab_conf:(elab_conf ~legacy:true ctxt) ~allow_forged:true value_type (Micheline.root value) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 189ef64c005a..7198bfff63ea 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1059,7 +1059,7 @@ let apply_manager_operation : ctxt parameters in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let+ ctxt, res, ops = match Entrypoint.to_string entrypoint with | "default" -> @@ -1290,7 +1290,7 @@ let apply_manager_operation : let* Ex_script parsed_script, ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged_in_storage:false script in @@ -1298,7 +1298,7 @@ let apply_manager_operation : let views_result = Script_ir_translator.parse_views ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) storage_type views in diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 115979be4778..4ec4d9eece40 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -54,7 +54,7 @@ let info_encoding = (opt "script" Script.encoding) (opt "counter" Manager_counter.encoding_for_RPCs) -let legacy = Script_ir_translator_config.make ~legacy:true () +let legacy ctxt = Script_ir_translator_config.make ~legacy:true ctxt module S = struct open Data_encoding @@ -311,7 +311,7 @@ module S = struct let*! tzresult = Script_ir_translator.parse_script ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged_in_storage:true script in @@ -421,7 +421,7 @@ let register () = let* value, ctxt = parse_data ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged:true value_type (Micheline.root value) @@ -450,7 +450,7 @@ let register () = let* value, ctxt = parse_data ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged:true value_type (Micheline.root value) @@ -523,7 +523,7 @@ let register () = let* Ex_script (Script {storage; storage_type; _}), ctxt = parse_script ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged_in_storage:true script in @@ -659,7 +659,7 @@ let register () = let* Ex_script (Script script), ctxt = parse_script ctxt - ~elab_conf:legacy + ~elab_conf:(legacy ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index e3595b2c2acd..780dc6075e9f 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -374,7 +374,7 @@ let init chain_id ctxt block_header = let* Ex_script (Script parsed_script), ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged_in_storage script in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index a8082f48e8e0..7d1ab001044c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -76,7 +76,7 @@ let make_transaction ctxt ~parameters_ty ~unparsed_parameters ~destination let+ parameters, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged:true parameters_ty (Micheline.root unparsed_parameters) diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index b0fe7ca2ec4b..5d1dd2b499c4 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -62,7 +62,7 @@ let get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = let+ x, ctxt = parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged:true value_type (Micheline.root value) diff --git a/src/proto_alpha/lib_protocol/script_cache.ml b/src/proto_alpha/lib_protocol/script_cache.ml index 472a49fbb685..8d77e3109223 100644 --- a/src/proto_alpha/lib_protocol/script_cache.ml +++ b/src/proto_alpha/lib_protocol/script_cache.ml @@ -48,7 +48,7 @@ let load_and_elaborate ctxt addr = parse_script ctxt script - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged_in_storage:true in (* We consume gas after the fact in order to not have to instrument diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index fee974aeb0c0..7904f66eeebe 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -562,7 +562,7 @@ module Raw = struct let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack in - let legacy = Script_ir_translator_config.make ~legacy:true () in + let legacy = Script_ir_translator_config.make ~legacy:true ctxt in match addr.destination with | Contract (Implicit _) | Sc_rollup _ | Zk_rollup _ -> (return_none [@ocaml.tailcall]) ctxt @@ -1769,7 +1769,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty) let arg = Micheline.root arg in parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged:internal entrypoint_ty arg @@ -1805,7 +1805,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal Script_ir_translator_config.make ~legacy:true ~keep_extra_types_for_interpreter_logging:(Option.is_some logger) - () + ctxt in let* ( Ex_script (Script diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 0b176469fd6b..94c92585ac99 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -785,7 +785,7 @@ let unpack ctxt ~ty ~bytes = let*! value_opt = parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~allow_forged:false ty (Micheline.root expr) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 2fcb84fe85c0..252ca8678a86 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5302,7 +5302,9 @@ let typecheck_code : type_map := (loc, (stack_ty_before, stack_ty_after)) :: !type_map in let type_logger = if show_types then Some type_logger else None in - let elab_conf = Script_ir_translator_config.make ~legacy ?type_logger () in + let elab_conf = + Script_ir_translator_config.make ~legacy ?type_logger ctxt + in let result = parse_kdescr ~unparse_code_rec @@ -5425,7 +5427,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage let* storage, ctxt = parse_storage ~unparse_code_rec - ~elab_conf:(Script_ir_translator_config.make ~legacy ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy ctxt) ctxt ~allow_forged:allow_forged_in_storage storage_type @@ -5963,7 +5965,8 @@ let parse_script ~elab_conf ctxt ~allow_forged_in_storage script = let parse_comparable_data ?type_logger ctxt ty t = parse_data - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ?type_logger ()) + ~elab_conf: + Script_ir_translator_config.(make ~legacy:false ?type_logger ctxt) ~allow_forged:false ctxt ty diff --git a/src/proto_alpha/lib_protocol/script_ir_translator_config.ml b/src/proto_alpha/lib_protocol/script_ir_translator_config.ml index a8c535735b08..0c14ae98b22f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator_config.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator_config.ml @@ -75,7 +75,7 @@ type elab_config = { legacy : bool; (** If set to true, it enables the legacy mode (see above). *) } -(** [make ?type_logger ?logging_enabled ~legacy ()] creates an [elab_config] +(** [make ?type_logger ?logging_enabled ~legacy ctxt] creates an [elab_config] record to be passed to parsing functions in [Script_ir_translator]. Note: [?logging_enabled] defaults to [false], because it only ever should @@ -85,7 +85,10 @@ let make : ?type_logger:type_logger -> ?keep_extra_types_for_interpreter_logging:bool -> legacy:bool -> - unit -> + context -> elab_config = - fun ?type_logger ?(keep_extra_types_for_interpreter_logging = false) ~legacy () -> + fun ?type_logger + ?(keep_extra_types_for_interpreter_logging = false) + ~legacy + _ctxt -> {type_logger; keep_extra_types_for_interpreter_logging; legacy} diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 1e0105efd4c7..24c613084e51 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -777,7 +777,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct and unparse_code_rec ctxt ~stack_depth mode code = let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:true () in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in let*? ctxt = Gas.consume ctxt Unparse_costs.unparse_instr_cycle in let non_terminal_recursion ctxt mode code = if Compare.Int.(stack_depth > 10_000) then diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 7f3b6208f541..381559722241 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -447,7 +447,7 @@ let initial_alpha_context ?(commitments = []) constants let* Ex_script (Script parsed_script), ctxt = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml index fa18ed71408e..3beb36c954a7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_annotations.ml @@ -86,7 +86,7 @@ let get_address_from_storage inc factory_addr = let*! res = Script_ir_translator.parse_data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) ~allow_forged:false option_address_t (Micheline.root factory_storage) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml index 7c4f246a9686..21b892f04a43 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_lambda_normalization.ml @@ -44,7 +44,7 @@ let new_ctxt () = let parse_and_project (ty : ((_, _) lambda, _) ty) (node : Script.node) = let open Lwt_result_wrap_syntax in let* ctxt = new_ctxt () in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let*@ lam, _ctxt = Script_ir_translator.parse_data ~elab_conf ctxt ~allow_forged:false ty node in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml index 1e186dfc0835..4eb787ccd235 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_patched_contracts.ml @@ -172,7 +172,7 @@ module Legacy_patch_test (Patches : LEGACY_SCRIPT_PATCHES) : let* _code, _ctxt = Lwt.map Environment.wrap_tzresult @@ Script_ir_translator.parse_code - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ctxt) ~code:(Script_repr.lazy_expr code) ctxt in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml index cbc00cf51319..bd21ffba4dae 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_sapling.ml @@ -1049,7 +1049,8 @@ module Interpreter_tests = struct let*@ Ex_script (Script script), ctxt = Script_ir_translator.parse_script ctx_without_gas_2 - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf: + (Script_ir_translator_config.make ~legacy:true ctx_without_gas_2) ~allow_forged_in_storage:true script in @@ -1193,7 +1194,8 @@ module Interpreter_tests = struct let*@ (state_1, state_2), _ctx = Script_ir_translator.parse_storage ctx_without_gas - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf: + (Script_ir_translator_config.make ~legacy:true ctx_without_gas) ~allow_forged:true tytype ~storage:storage_lazy_expr diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 3d4c29b44b3f..4e3a020c40e1 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -356,7 +356,7 @@ let origination_operation ctxt ~sender ~script:(code, storage) ~orig_contract = ctxt ) = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml index 0270f2d08349..862a47228863 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_manager.ml @@ -93,7 +93,7 @@ let ticket_balance_of_storage ctxt (contract : Alpha_context.Contract.t) = ctxt ) = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index ae967de5eb54..5a59c1b4822a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -279,7 +279,7 @@ let origination_operation block ~sender ~baker ~script ~storage ~forges_tickets ctxt ) = Script_ir_translator.parse_script ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:true ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:true ctxt) ~allow_forged_in_storage:true script in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index cc4c193a2094..45f86bf97f10 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -137,7 +137,7 @@ let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = let*@ value, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:(Script_ir_translator_config.make ~legacy:false ()) + ~elab_conf:(Script_ir_translator_config.make ~legacy:false ctxt) ~allow_forged:true ty node diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 5faf2ce4e7b3..f6b7e74a3205 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -414,7 +414,7 @@ let test_unparse_comb_comparable_type () = let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = let open Lwt_result_wrap_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let allow_forged = true in let*@ actual, ctxt = Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node @@ -424,7 +424,7 @@ let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = let test_parse_data_fails loc ctxt ty node = let open Lwt_result_wrap_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in let allow_forged = false in let*! result = Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node @@ -808,11 +808,11 @@ let gas_monad_run ctxt m = *) let test_contract_not_packable () = let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:false () in let contract_unit = Prim (0, Script.T_contract, [Prim (0, T_unit, [], [])], []) in let* ctxt = test_context () in + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt in (* Test that [contract_unit] is parsable *) let* () = match diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 2251ff68f74f..0bbb73d6ceee 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -361,7 +361,7 @@ let verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters = let* parsed_unparsed_parameters, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged:true parameters_ty (Environment.Micheline.root unparsed_parameters) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index bacc7280a7a4..de30d7d4d473 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -496,7 +496,7 @@ module Ticket_collection = struct let+ v, ctxt = Script_ir_translator.parse_data ~elab_conf: - Script_ir_translator_config.(make ~legacy:true ()) + Script_ir_translator_config.(make ~legacy:true ctxt) ctxt ~allow_forged:true value_type @@ -546,7 +546,7 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr = let* value, ctxt = Script_ir_translator.parse_data ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) ~allow_forged:true ty expr -- GitLab From 364d933aa3193d168f4f4a701f91bbb16fa3b9dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 14:31:36 +0200 Subject: [PATCH 02/12] rollup feature flags in elab conf --- .../lib_protocol/script_ir_translator_config.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator_config.ml b/src/proto_alpha/lib_protocol/script_ir_translator_config.ml index 0c14ae98b22f..84e6ec366d50 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator_config.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator_config.ml @@ -73,6 +73,8 @@ type elab_config = { result in a crash. This cannot be helped at the moment, but since logging is never enabled during validation, we should be safe. *) legacy : bool; (** If set to true, it enables the legacy mode (see above). *) + sc_rollup_enable : bool; + zk_rollup_enable : bool; } (** [make ?type_logger ?logging_enabled ~legacy ctxt] creates an [elab_config] @@ -90,5 +92,11 @@ let make : fun ?type_logger ?(keep_extra_types_for_interpreter_logging = false) ~legacy - _ctxt -> - {type_logger; keep_extra_types_for_interpreter_logging; legacy} + ctxt -> + { + type_logger; + keep_extra_types_for_interpreter_logging; + legacy; + sc_rollup_enable = Constants.sc_rollup_enable ctxt; + zk_rollup_enable = Constants.zk_rollup_enable ctxt; + } -- GitLab From 3c36ea0820eaeb3d2a63c6cbf54af972b10564f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 15:44:42 +0200 Subject: [PATCH 03/12] rollup feature flags taken from elab_conf instead of ctxt --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 252ca8678a86..c40c680e07ca 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2237,8 +2237,8 @@ let rec parse_data : | Address_t, expr -> traced_from_gas_monad ctxt @@ parse_address - ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) - ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) + ~sc_rollup_enable:elab_conf.sc_rollup_enable + ~zk_rollup_enable:elab_conf.zk_rollup_enable expr | Contract_t (arg_ty, _), expr -> traced -- GitLab From 8bc2c3ce1333bc04dde065077515d70a85161e98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 00:09:32 +0200 Subject: [PATCH 04/12] check_dupable_ty in gas monad --- .../lib_protocol/script_ir_translator.ml | 41 +++++++++---------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index c40c680e07ca..d6281be5a9fa 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -190,11 +190,10 @@ let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function | Pair_t _ | Or_t _ | Option_t _ -> () -let check_dupable_ty ctxt loc ty = - let open Result_syntax in - let rec aux : type a ac. location -> (a, ac) ty -> (unit, error) Gas_monad.t = - fun loc ty -> - let open Gas_monad.Syntax in +let rec check_dupable_ty : + type a ac. location -> (a, ac) ty -> (unit, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun loc ty -> let*$ () = Typecheck_costs.check_dupable_cycle in match ty with | Unit_t -> return_unit @@ -221,13 +220,13 @@ let check_dupable_ty ctxt loc ty = | Sapling_transaction_deprecated_t _ -> return_unit | Chest_t -> return_unit | Chest_key_t -> return_unit - | Ticket_t _ -> fail @@ Unexpected_ticket loc + | Ticket_t _ -> tzfail @@ Unexpected_ticket loc | Pair_t (ty_a, ty_b, _, _) -> - let* () = aux loc ty_a in - aux loc ty_b + let* () = check_dupable_ty loc ty_a in + check_dupable_ty loc ty_b | Or_t (ty_a, ty_b, _, _) -> - let* () = aux loc ty_a in - aux loc ty_b + let* () = check_dupable_ty loc ty_a in + check_dupable_ty loc ty_b | Lambda_t (_, _, _) -> (* Lambda are dupable as long as: @@ -238,21 +237,17 @@ let check_dupable_ty ctxt loc ty = Hence non-dupable should imply non-packable. *) return_unit - | Option_t (ty, _, _) -> aux loc ty - | List_t (ty, _) -> aux loc ty + | Option_t (ty, _, _) -> check_dupable_ty loc ty + | List_t (ty, _) -> check_dupable_ty loc ty | Set_t (key_ty, _) -> let () = check_dupable_comparable_ty key_ty in return_unit | Map_t (key_ty, val_ty, _) -> let () = check_dupable_comparable_ty key_ty in - aux loc val_ty + check_dupable_ty loc val_ty | Big_map_t (key_ty, val_ty, _) -> let () = check_dupable_comparable_ty key_ty in - aux loc val_ty - in - let gas = aux loc ty in - let* res, ctxt = Gas_monad.run ctxt gas in - match res with Ok () -> return ctxt | Error e -> tzfail e + check_dupable_ty loc val_ty let type_metadata_eq : type error_trace. @@ -2832,12 +2827,13 @@ and parse_instr : tzfail (Invalid_arity (loc, I_DROP, 1, List.length l)) | Prim (loc, I_DUP, [], annot), (Item_t (v, _) as stack) -> let*? () = check_var_annot loc annot in - let*? ctxt = + let*? res, ctxt = Gas_monad.run ctxt @@ check_dupable_ty loc v in + let*? () = record_trace_eval (fun () -> let t = serialize_ty_for_error v in Non_dupable_type (loc, t)) - (check_dupable_ty ctxt loc v) + res in let dup = {apply = (fun k -> IDup (loc, k))} in typed ctxt loc dup (Item_t (v, stack)) @@ -2867,12 +2863,13 @@ and parse_instr : let*? (Dup_n_proof_argument (witness, after_ty)) = record_trace (Dup_n_bad_stack loc) (make_proof_argument n stack_ty) in - let*? ctxt = + let*? res, ctxt = Gas_monad.run ctxt (check_dupable_ty loc after_ty) in + let*? () = record_trace_eval (fun () -> let t = serialize_ty_for_error after_ty in Non_dupable_type (loc, t)) - (check_dupable_ty ctxt loc after_ty) + res in let dupn = {apply = (fun k -> IDup_n (loc, n, witness, k))} in typed ctxt loc dupn (Item_t (after_ty, stack_ty)) -- GitLab From 2023a3741191896e69ac066f05cd41d753546792 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 09:00:07 +0200 Subject: [PATCH 05/12] stack_eq in error monad --- .../lib_protocol/script_ir_translator.ml | 61 ++++++++++++------- 1 file changed, 40 insertions(+), 21 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d6281be5a9fa..4fe9e03b3ed8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -446,23 +446,23 @@ let ty_eq : let rec stack_eq : type ta tb ts tu. Script.location -> - context -> int -> (ta, ts) stack_ty -> (tb, tu) stack_ty -> - (((ta, ts) stack_ty, (tb, tu) stack_ty) eq * context) tzresult = - let open Result_syntax in - fun loc ctxt lvl stack1 stack2 -> + (((ta, ts) stack_ty, (tb, tu) stack_ty) eq, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun loc lvl stack1 stack2 -> match (stack1, stack2) with - | Bot_t, Bot_t -> return (Eq, ctxt) + | Bot_t, Bot_t -> return Eq | Item_t (ty1, rest1), Item_t (ty2, rest2) -> - let* eq, ctxt = - Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) ty1 ty2 - |> record_trace (Bad_stack_item lvl) + let* Eq = + let error_details = Informative loc in + ty_eq ~error_details ty1 ty2 + |> Gas_monad.record_trace_eval ~error_details (fun _loc -> + Bad_stack_item lvl) in - let* Eq = eq in - let+ Eq, ctxt = stack_eq loc ctxt (lvl + 1) rest1 rest2 in - ((Eq : ((ta, ts) stack_ty, (tb, tu) stack_ty) eq), ctxt) + let+ Eq = stack_eq loc (lvl + 1) rest1 rest2 in + (Eq : ((ta, ts) stack_ty, (tb, tu) stack_ty) eq) | _, _ -> tzfail Bad_stack_length (* ---- Type checker results -------------------------------------------------*) @@ -502,8 +502,9 @@ let merge_branches : in record_trace_eval unmatched_branches - (let+ Eq, ctxt = stack_eq loc ctxt 1 aftbt aftbf in - (Typed (branch dbt dbf), ctxt)) + (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aftbt aftbf in + let* Eq = eq in + return (Typed (branch dbt dbf), ctxt)) | Failed {descr = descrt}, Failed {descr = descrf} -> let descr ret = branch (descrt ret) (descrf ret) in return (Failed {descr}, ctxt) @@ -2978,7 +2979,10 @@ and parse_instr : in record_trace_eval invalid_map_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft_rest rest in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 aft_rest rest + in + let* Eq = eq in let* opt_ty = option_t loc ret in let final_stack = Item_t (opt_ty, rest) in let body = kibody.instr.apply (IHalt loc) in @@ -3222,7 +3226,10 @@ and parse_instr : in record_trace_eval invalid_map_body - (let* Eq, ctxt = stack_eq loc ctxt 1 rest starting_rest in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 rest starting_rest + in + let* Eq = eq in let hloc = loc in let ibody = kibody.instr.apply (IHalt hloc) in let* ty = list_t loc ret in @@ -3265,7 +3272,8 @@ and parse_instr : in record_trace_eval invalid_iter_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in + (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aft rest in + let* Eq = eq in typed_no_lwt ctxt loc (mk_list_iter ibody) rest) | Failed {descr} -> typed_no_lwt ctxt loc (mk_list_iter (descr rest)) rest ) @@ -3307,7 +3315,8 @@ and parse_instr : in record_trace_eval invalid_iter_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in + (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aft rest in + let* Eq = eq in typed_no_lwt ctxt loc (mk_iset_iter ibody) rest) | Failed {descr} -> typed_no_lwt ctxt loc (mk_iset_iter (descr rest)) rest ) @@ -3363,7 +3372,10 @@ and parse_instr : in record_trace_eval invalid_map_body - (let* Eq, ctxt = stack_eq loc ctxt 1 rest starting_rest in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 rest starting_rest + in + let* Eq = eq in let* ty = map_t loc kt ret in let instr = { @@ -3409,7 +3421,8 @@ and parse_instr : in record_trace_eval invalid_iter_body - (let* Eq, ctxt = stack_eq loc ctxt 1 aft rest in + (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aft rest in + let* Eq = eq in typed_no_lwt ctxt loc (make_instr ibody) rest) | Failed {descr} -> typed_no_lwt ctxt loc (make_instr (descr rest)) rest) | Prim (loc, I_MEM, [], annot), Item_t (vk, Item_t (Map_t (k, _, _), rest)) -> @@ -3612,7 +3625,10 @@ and parse_instr : in record_trace_eval unmatched_branches - (let* Eq, ctxt = stack_eq loc ctxt 1 ibody.aft stack in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 ibody.aft stack + in + let* Eq = eq in let instr = { apply = @@ -3654,7 +3670,10 @@ and parse_instr : in record_trace_eval unmatched_branches - (let* Eq, ctxt = stack_eq loc ctxt 1 ibody.aft stack in + (let* eq, ctxt = + Gas_monad.run ctxt @@ stack_eq loc 1 ibody.aft stack + in + let* Eq = eq in let instr = { apply = -- GitLab From e99706259815cffc0e83543de9c04f28ca48d07b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 09:31:22 +0200 Subject: [PATCH 06/12] context free serialize_stack_for_error --- .../lib_protocol/script_ir_translator.ml | 82 +++++++++---------- .../lib_protocol/script_ir_unparser.ml | 5 +- .../lib_protocol/script_ir_unparser.mli | 7 +- 3 files changed, 45 insertions(+), 49 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 4fe9e03b3ed8..be6f51193211 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -496,8 +496,8 @@ let merge_branches : match (btr, bfr) with | Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf) -> let unmatched_branches () = - let aftbt = serialize_stack_for_error ctxt aftbt in - let aftbf = serialize_stack_for_error ctxt aftbf in + let aftbt = serialize_stack_for_error aftbt in + let aftbf = serialize_stack_for_error aftbf in Unmatched_branches (loc, aftbt, aftbf) in record_trace_eval @@ -1234,7 +1234,7 @@ let rec make_comb_set_proof_argument : Comb_set_proof_argument (Comb_set_plus_two comb_set_left_witness, after_ty) | _ -> - let whole_stack = serialize_stack_for_error ctxt stack_ty in + let whole_stack = serialize_stack_for_error stack_ty in tzfail (Bad_stack (loc, I_UPDATE, 2, whole_stack)) type 'a ex_ty_cstr = @@ -2547,9 +2547,9 @@ and parse_view : ctxt ) | Typed ({loc; aft; _} as descr) -> ( let ill_type_view stack_ty loc = - let actual = serialize_stack_for_error ctxt stack_ty in + let actual = serialize_stack_for_error stack_ty in let expected_stack = Item_t (output_ty, Bot_t) in - let expected = serialize_stack_for_error ctxt expected_stack in + let expected = serialize_stack_for_error expected_stack in Ill_typed_view {loc; actual; expected} in let open Result_syntax in @@ -2627,7 +2627,7 @@ and parse_kdescr : Gas_monad.run ctxt @@ Gas_monad.record_trace_eval ~error_details (fun loc -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in Bad_return (loc, stack_ty, ret)) @@ ty_eq ~error_details ty ret in @@ -2635,9 +2635,9 @@ and parse_kdescr : return ( (close_descr descr : (arg, end_of_stack, ret, end_of_stack) kdescr), ctxt ) - | Typed {loc; aft = stack_ty; _}, ctxt -> + | Typed {loc; aft = stack_ty; _}, _ctxt -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in tzfail @@ Bad_return (loc, stack_ty, ret) | Failed {descr}, ctxt -> return @@ -2686,7 +2686,7 @@ and parse_lam_rec : Gas_monad.run ctxt @@ Gas_monad.record_trace_eval ~error_details (fun loc -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in Bad_return (loc, stack_ty, ret)) @@ ty_eq ~error_details ty ret in @@ -2706,9 +2706,9 @@ and parse_lam_rec : ctxt closed_descr script_instr - | Typed {loc; aft = stack_ty; _}, ctxt -> + | Typed {loc; aft = stack_ty; _}, _ctxt -> let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in tzfail @@ Bad_return (loc, stack_ty, ret) | Failed {descr}, ctxt -> (normalized_lam_rec [@ocaml.tailcall]) @@ -2743,7 +2743,7 @@ and parse_instr : loc name n m : ((a, b) eq * context) tzresult = let open Result_syntax in record_trace_eval (fun () -> - let stack_ty = serialize_stack_for_error ctxt stack_ty in + let stack_ty = serialize_stack_for_error stack_ty in Bad_stack (loc, name, m, stack_ty)) @@ record_trace (Bad_stack_item n) @@ -2785,8 +2785,8 @@ and parse_instr : script_instr stack_ty in - let bad_stack_error ctxt loc prim relevant_stack_portion = - let whole_stack = serialize_stack_for_error ctxt stack_ty in + let bad_stack_error _ctxt loc prim relevant_stack_portion = + let whole_stack = serialize_stack_for_error stack_ty in Result_syntax.tzfail (Bad_stack (loc, prim, relevant_stack_portion, whole_stack)) in @@ -2813,7 +2813,7 @@ and parse_instr : in Dropn_proof_argument (KPrefix (loc, a, n'), stack_after_drops) | _, _ -> - let whole_stack = serialize_stack_for_error ctxt whole_stack in + let whole_stack = serialize_stack_for_error whole_stack in tzfail (Bad_stack (loc, I_DROP, whole_n, whole_stack)) in let*? () = error_unexpected_annot loc result_annot in @@ -2889,7 +2889,7 @@ and parse_instr : in Dig_proof_argument (KPrefix (loc, v, n'), x, Item_t (v, aft')) | _, _ -> - let whole_stack = serialize_stack_for_error ctxt stack in + let whole_stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_DIG, 3, whole_stack)) in let*? n = parse_uint10 n in @@ -2906,14 +2906,14 @@ and parse_instr : let*? () = error_unexpected_annot loc result_annot in match make_dug_proof_argument loc whole_n x whole_stack with | None -> - let whole_stack = serialize_stack_for_error ctxt whole_stack in + let whole_stack = serialize_stack_for_error whole_stack in tzfail (Bad_stack (loc, I_DUG, whole_n, whole_stack)) | Some (Dug_proof_argument (n', aft)) -> let dug = {apply = (fun k -> IDug (loc, whole_n, n', k))} in typed ctxt loc dug aft) | Prim (loc, I_DUG, [_], result_annot), stack -> let*? () = error_unexpected_annot loc result_annot in - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_DUG, 1, stack)) | Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _ -> tzfail (Invalid_arity (loc, I_DUG, 1, List.length l)) @@ -2974,7 +2974,7 @@ and parse_instr : match judgement with | Typed ({loc; aft = Item_t (ret, aft_rest); _} as kibody) -> let invalid_map_body () = - let aft = serialize_stack_for_error ctxt kibody.aft in + let aft = serialize_stack_for_error kibody.aft in Invalid_map_body (loc, aft) in record_trace_eval @@ -2989,7 +2989,7 @@ and parse_instr : let apply k = IOpt_map {loc; body; k} in typed_no_lwt ctxt loc {apply} final_stack) | Typed {aft = Bot_t; _} -> - let aft = serialize_stack_for_error ctxt Bot_t in + let aft = serialize_stack_for_error Bot_t in tzfail (Invalid_map_body (loc, aft)) | Failed _ -> tzfail (Invalid_map_block_fail loc)) | ( Prim (loc, I_IF_NONE, [bt; bf], annot), @@ -3082,7 +3082,7 @@ and parse_instr : let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in match make_comb_get_proof_argument n comb_ty with | None -> - let whole_stack = serialize_stack_for_error ctxt stack_ty in + let whole_stack = serialize_stack_for_error stack_ty in tzfail (Bad_stack (loc, I_GET, 1, whole_stack)) | Some (Comb_get_proof_argument (witness, ty')) -> let after_stack_ty = Item_t (ty', rest_ty) in @@ -3221,7 +3221,7 @@ and parse_instr : match judgement with | Typed ({aft = Item_t (ret, rest) as aft; _} as kibody) -> let invalid_map_body () = - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in Invalid_map_body (loc, aft) in record_trace_eval @@ -3242,7 +3242,7 @@ and parse_instr : let stack = Item_t (ty, rest) in typed_no_lwt ctxt loc list_map stack) | Typed {aft; _} -> - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in tzfail (Invalid_map_body (loc, aft)) | Failed _ -> tzfail (Invalid_map_block_fail loc)) | Prim (loc, I_ITER, [body], annot), Item_t (List_t (elt, _), rest) -> ( @@ -3266,8 +3266,8 @@ and parse_instr : match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let rest = serialize_stack_for_error ctxt rest in + let aft = serialize_stack_for_error ibody.aft in + let rest = serialize_stack_for_error rest in Invalid_iter_body (loc, rest, aft) in record_trace_eval @@ -3309,8 +3309,8 @@ and parse_instr : match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let rest = serialize_stack_for_error ctxt rest in + let aft = serialize_stack_for_error ibody.aft in + let rest = serialize_stack_for_error rest in Invalid_iter_body (loc, rest, aft) in record_trace_eval @@ -3367,7 +3367,7 @@ and parse_instr : match judgement with | Typed ({aft = Item_t (ret, rest) as aft; _} as ibody) -> let invalid_map_body () = - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in Invalid_map_body (loc, aft) in record_trace_eval @@ -3389,7 +3389,7 @@ and parse_instr : let stack = Item_t (ty, rest) in typed_no_lwt ctxt loc instr stack) | Typed {aft; _} -> - let aft = serialize_stack_for_error ctxt aft in + let aft = serialize_stack_for_error aft in tzfail (Invalid_map_body (loc, aft)) | Failed _ -> tzfail (Invalid_map_block_fail loc)) | Prim (loc, I_ITER, [body], annot), Item_t (Map_t (key, element_ty, _), rest) @@ -3415,8 +3415,8 @@ and parse_instr : match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let rest = serialize_stack_for_error ctxt rest in + let aft = serialize_stack_for_error ibody.aft in + let rest = serialize_stack_for_error rest in Invalid_iter_body (loc, rest, aft) in record_trace_eval @@ -3619,8 +3619,8 @@ and parse_instr : match judgement with | Typed ibody -> let unmatched_branches () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let stack = serialize_stack_for_error ctxt stack in + let aft = serialize_stack_for_error ibody.aft in + let stack = serialize_stack_for_error stack in Unmatched_branches (loc, aft, stack) in record_trace_eval @@ -3664,8 +3664,8 @@ and parse_instr : match judgement with | Typed ibody -> let unmatched_branches () = - let aft = serialize_stack_for_error ctxt ibody.aft in - let stack = serialize_stack_for_error ctxt stack in + let aft = serialize_stack_for_error ibody.aft in + let stack = serialize_stack_for_error stack in Unmatched_branches (loc, aft, stack) in record_trace_eval @@ -3829,7 +3829,7 @@ and parse_instr : let w = KPrefix (loc, v, n') in Dipn_proof_argument (w, ctxt, descr, Item_t (v, aft')) | _, _ -> - let whole_stack = serialize_stack_for_error ctxt stack in + let whole_stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_DIP, 1, whole_stack)) in let*? () = error_unexpected_annot loc result_annot in @@ -4763,13 +4763,13 @@ and parse_instr : let t = serialize_ty_for_error t in tzfail (Undefined_unop (loc, name, t)) | Prim (loc, ((I_UPDATE | I_SLICE | I_OPEN_CHEST) as name), [], _), stack -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, name, 3, stack)) | Prim (loc, I_CREATE_CONTRACT, _, _), stack -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) | Prim (loc, I_TRANSFER_TOKENS, [], _), stack -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)) | ( Prim ( loc, @@ -4784,7 +4784,7 @@ and parse_instr : _, _ ), stack ) -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, name, 1, stack)) | ( Prim ( loc, @@ -4795,7 +4795,7 @@ and parse_instr : _, _ ), stack ) -> - let stack = serialize_stack_for_error ctxt stack in + let stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, name, 2, stack)) (* Generic parsing errors *) | expr, _ -> diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 24c613084e51..4acddaaca87e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -182,10 +182,7 @@ let rec unparse_stack_uncarbonated : let urest = unparse_stack_uncarbonated rest in strip_locations uty :: urest -let serialize_stack_for_error ctxt stack_ty = - match Gas.level ctxt with - | Unaccounted -> unparse_stack_uncarbonated stack_ty - | Limited _ -> [] +let serialize_stack_for_error stack_ty = unparse_stack_uncarbonated stack_ty let unparse_unit ~loc () = Gas_monad.return (Prim (loc, D_Unit, [], [])) diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 965d95e8403d..f63e77685520 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -46,10 +46,9 @@ type ('ty, 'depth) comb_witness = when this function is called, the operation must have already failed. *) val serialize_ty_for_error : ('a, 'b) ty -> Script.expr -(** [serialize_stack_for_error ctxt stack_ty] returns a Micheline representation of - [stack_ty] as a list of Micheline expressions ONLY IF gas is unlimited - in [ctxt]. Otherwise returns an empty list. *) -val serialize_stack_for_error : context -> ('a, 'b) stack_ty -> Script.expr list +(** [serialize_stack_for_error stack_ty] returns a Micheline representation of + [stack_ty] as a list of Micheline expressions. *) +val serialize_stack_for_error : ('a, 'b) stack_ty -> Script.expr list (** [unparse_ty ~loc ty] returns the Micheline representation of a given type. *) -- GitLab From 4779bdc40c302d1b62c544e832e95d8540a97966 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 09:56:44 +0200 Subject: [PATCH 07/12] ctxt free bad stack error --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index be6f51193211..1f7c22a36dca 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2785,7 +2785,7 @@ and parse_instr : script_instr stack_ty in - let bad_stack_error _ctxt loc prim relevant_stack_portion = + let bad_stack_error loc prim relevant_stack_portion = let whole_stack = serialize_stack_for_error stack_ty in Result_syntax.tzfail (Bad_stack (loc, prim, relevant_stack_portion, whole_stack)) @@ -2854,7 +2854,7 @@ and parse_instr : make_proof_argument (n - 1) tl_ty in Dup_n_proof_argument (Dup_n_succ dup_n_witness, b_ty) - | _ -> bad_stack_error ctxt loc I_DUP 1 + | _ -> bad_stack_error loc I_DUP 1 in let*? n = parse_uint10 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in @@ -3037,7 +3037,7 @@ and parse_instr : let+ (Ty_ex_c pair_t) = pair_t loc a_ty b_ty in Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) - | _ -> bad_stack_error ctxt loc I_PAIR 1 + | _ -> bad_stack_error loc I_PAIR 1 in let*? n = parse_uint10 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in @@ -3064,7 +3064,7 @@ and parse_instr : in Uncomb_proof_argument (Uncomb_succ uncomb_witness, Item_t (a_ty, after_ty)) - | _ -> bad_stack_error ctxt loc I_UNPAIR 1 + | _ -> bad_stack_error loc I_UNPAIR 1 in let*? n = parse_uint10 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in -- GitLab From 87d3d8692504b330ea5a47cd9fdb0ea0f1831792 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 09:03:48 +0200 Subject: [PATCH 08/12] merge branches in gas monad --- .../lib_protocol/script_ir_translator.ml | 45 ++++++++++++------- 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 1f7c22a36dca..2ce323bf007e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -485,14 +485,13 @@ type ('a, 's, 'b, 'u, 'c, 'v) branch = { let merge_branches : type a s b u c v. - context -> Script.location -> (a, s) judgement -> (b, u) judgement -> (a, s, b, u, c, v) branch -> - ((c, v) judgement * context) tzresult = - let open Result_syntax in - fun ctxt loc btr bfr {branch} -> + ((c, v) judgement, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun loc btr bfr {branch} -> match (btr, bfr) with | Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf) -> let unmatched_branches () = @@ -500,18 +499,18 @@ let merge_branches : let aftbf = serialize_stack_for_error aftbf in Unmatched_branches (loc, aftbt, aftbf) in - record_trace_eval + Gas_monad.record_trace_eval + ~error_details:(Informative ()) unmatched_branches - (let* eq, ctxt = Gas_monad.run ctxt @@ stack_eq loc 1 aftbt aftbf in - let* Eq = eq in - return (Typed (branch dbt dbf), ctxt)) + (let+ Eq = stack_eq loc 1 aftbt aftbf in + Typed (branch dbt dbf)) | Failed {descr = descrt}, Failed {descr = descrf} -> let descr ret = branch (descrt ret) (descrf ret) in - return (Failed {descr}, ctxt) + return (Failed {descr}) | Typed dbt, Failed {descr = descrf} -> - return (Typed (branch dbt (descrf dbt.aft)), ctxt) + return (Typed (branch dbt (descrf dbt.aft))) | Failed {descr = descrt}, Typed dbf -> - return (Typed (branch (descrt dbf.aft) dbf), ctxt) + return (Typed (branch (descrt dbf.aft) dbf)) let parse_memo_size (n : (location, _) Micheline.node) : Sapling.Memo_size.t tzresult = @@ -3013,7 +3012,11 @@ and parse_instr : in {loc; instr = ifnone; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) (* pairs *) | Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest)) -> let*? () = check_constr_annot loc annot in @@ -3158,7 +3161,11 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) (* lists *) | Prim (loc, I_NIL, [t], annot), stack -> let*? t, ctxt = @@ -3199,7 +3206,11 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest) -> let*? () = check_var_type_annot loc annot in let list_size = {apply = (fun k -> IList_size (loc, k))} in @@ -3608,7 +3619,11 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - Lwt.return @@ merge_branches ctxt loc btr bfr {branch} + let*? res, ctxt = + Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} + in + let*? res in + return (res, ctxt) | Prim (loc, I_LOOP, [body], annot), (Item_t (Bool_t, rest) as stack) -> ( let*? () = check_kind [Seq_kind] body in let*? () = error_unexpected_annot loc annot in -- GitLab From 90995bb0af03457d786fd4414361eca88ca70619 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 09:04:10 +0200 Subject: [PATCH 09/12] context free make_comb_set_proof_argument --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 2ce323bf007e..660df4997ee0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1211,7 +1211,6 @@ let rec make_comb_get_proof_argument : let rec make_comb_set_proof_argument : type value valuec before beforec a s. - context -> (a, s) stack_ty -> location -> int -> @@ -1219,7 +1218,7 @@ let rec make_comb_set_proof_argument : (before, beforec) ty -> (value, before) comb_set_proof_argument tzresult = let open Result_syntax in - fun ctxt stack_ty loc n value_ty ty -> + fun stack_ty loc n value_ty ty -> match (n, ty) with | 0, _ -> return (Comb_set_proof_argument (Comb_set_zero, value_ty)) | 1, Pair_t (_hd_ty, tl_ty, _, _) -> @@ -1227,7 +1226,7 @@ let rec make_comb_set_proof_argument : Comb_set_proof_argument (Comb_set_one, after_ty) | n, Pair_t (hd_ty, tl_ty, _, _) -> let* (Comb_set_proof_argument (comb_set_left_witness, tl_ty')) = - make_comb_set_proof_argument ctxt stack_ty loc (n - 2) value_ty tl_ty + make_comb_set_proof_argument stack_ty loc (n - 2) value_ty tl_ty in let+ (Ty_ex_c after_ty) = pair_t loc hd_ty tl_ty' in Comb_set_proof_argument @@ -3097,7 +3096,7 @@ and parse_instr : let*? n = parse_uint11 n in let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in let*? (Comb_set_proof_argument (witness, after_ty)) = - make_comb_set_proof_argument ctxt stack_ty loc n value_ty comb_ty + make_comb_set_proof_argument stack_ty loc n value_ty comb_ty in let after_stack_ty = Item_t (after_ty, rest_ty) in let comb_set = {apply = (fun k -> IComb_set (loc, n, witness, k))} in -- GitLab From 09f0e4538acb2e728d7e7225381b82e25afe2a3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 09:27:59 +0200 Subject: [PATCH 10/12] remove ctxt from Dipnproof argument --- .../lib_protocol/script_ir_translator.ml | 23 +++++++++++-------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 660df4997ee0..1b30c40ae78e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1143,7 +1143,6 @@ type (_, _, _) dug_proof_argument = type (_, _) dipn_proof_argument = | Dipn_proof_argument : ('fa, 'fs, 'fb, 'fu, 'a, 's, 'b, 'u) stack_prefix_preservation_witness - * context * ('fa, 'fs, 'fb, 'fu) descr * ('b, 'u) stack_ty -> ('a, 's) dipn_proof_argument @@ -3823,8 +3822,11 @@ and parse_instr : let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in let rec make_proof_argument : type a s. - int -> (a, s) stack_ty -> (a, s) dipn_proof_argument tzresult Lwt.t = - fun n stk -> + int -> + (a, s) stack_ty -> + context -> + ((a, s) dipn_proof_argument * context) tzresult Lwt.t = + fun n stk ctxt -> match (Compare.Int.(n = 0), stk) with | true, rest -> ( let* judgement, ctxt = @@ -3833,22 +3835,23 @@ and parse_instr : match judgement with | Typed descr -> return - (Dipn_proof_argument (KRest, ctxt, descr, descr.aft) - : (a, s) dipn_proof_argument) + ( (Dipn_proof_argument (KRest, descr, descr.aft) + : (a, s) dipn_proof_argument), + ctxt ) | Failed _ -> tzfail (Fail_not_in_tail_position loc)) | false, Item_t (v, rest) -> - let+ (Dipn_proof_argument (n', ctxt, descr, aft')) = - make_proof_argument (n - 1) rest + let+ Dipn_proof_argument (n', descr, aft'), ctxt = + make_proof_argument (n - 1) rest ctxt in let w = KPrefix (loc, v, n') in - Dipn_proof_argument (w, ctxt, descr, Item_t (v, aft')) + (Dipn_proof_argument (w, descr, Item_t (v, aft')), ctxt) | _, _ -> let whole_stack = serialize_stack_for_error stack in tzfail (Bad_stack (loc, I_DIP, 1, whole_stack)) in let*? () = error_unexpected_annot loc result_annot in - let* (Dipn_proof_argument (n', ctxt, descr, aft)) = - make_proof_argument n stack + let* Dipn_proof_argument (n', descr, aft), ctxt = + make_proof_argument n stack ctxt in let b = descr.instr.apply (IHalt descr.loc) in let res = {apply = (fun k -> IDipn (loc, n, n', b, k))} in -- GitLab From 8fa96a23e7d5d912c437d88b84f2f8ef66b3e022 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 10:21:42 +0200 Subject: [PATCH 11/12] parse_view_name in gas monad --- .../lib_protocol/script_ir_translator.ml | 31 +++++++++++-------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 1b30c40ae78e..a23cff6eb97a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1913,8 +1913,9 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = - let open Result_syntax in +let parse_view_name : Script.node -> (Script_string.t, error trace) Gas_monad.t + = + let open Gas_monad.Syntax in function | String (loc, v) as expr -> (* The limitation of length of string is same as entrypoint *) @@ -1925,16 +1926,18 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) else tzfail (Bad_view_name loc) in - let* ctxt = Gas.consume ctxt (Typecheck_costs.check_printable v) in - record_trace - (Invalid_syntactic_constant - ( loc, - strip_locations expr, - "string [a-zA-Z0-9_.%@] and the maximum string length of 31 \ - characters" )) + let*$ () = Typecheck_costs.check_printable v in + Gas_monad.record_trace_eval + ~error_details:(Informative ()) + (fun () -> + Invalid_syntactic_constant + ( loc, + strip_locations expr, + "string [a-zA-Z0-9_.%@] and the maximum string length of 31 \ + characters" )) (let* v = check_char (String.length v - 1) in - let+ s = Script_string.of_string v in - (s, ctxt)) + let+? s = Script_string.of_string v in + s) | expr -> tzfail @@ Invalid_kind (location expr, [String_kind], kind expr) let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = @@ -1976,7 +1979,8 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = tzfail (Invalid_arity (loc, name, 1, List.length args)) | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _) :: rest -> - let* str, ctxt = parse_view_name ctxt name in + let* str, ctxt = Gas_monad.run ctxt @@ parse_view_name name in + let* str in let* ctxt = Gas.consume ctxt @@ -4295,7 +4299,8 @@ and parse_instr : | ( Prim (loc, I_VIEW, [name; output_ty], annot), Item_t (input_ty, Item_t (Address_t, rest)) ) -> let output_ty_loc = location output_ty in - let*? name, ctxt = parse_view_name ctxt name in + let*? name, ctxt = Gas_monad.run ctxt @@ parse_view_name name in + let*? name in let*? output_ty, ctxt = Gas_monad.run ctxt @@ parse_view_output_ty ~stack_depth:0 ~legacy output_ty -- GitLab From 296cc7746e023f7238c93f814e25351bd2ca448d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 12:16:11 +0200 Subject: [PATCH 12/12] parse_toplevel in gas monad --- .../lib_protocol/script_ir_translator.ml | 102 ++++++++++-------- 1 file changed, 55 insertions(+), 47 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a23cff6eb97a..fbfcc745feae 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1940,10 +1940,11 @@ let parse_view_name : Script.node -> (Script_string.t, error trace) Gas_monad.t s) | expr -> tzfail @@ Invalid_kind (location expr, [String_kind], kind expr) -let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = - let open Result_syntax in - fun ctxt toplevel -> - record_trace (Ill_typed_contract (toplevel, [])) +let parse_toplevel : Script.expr -> (toplevel, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun toplevel -> + Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> + Ill_typed_contract (toplevel, [])) @@ match root toplevel with | Int (loc, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Int_kind)) @@ -1951,9 +1952,9 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = | Bytes (loc, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Bytes_kind)) | Prim (loc, _, _, _) -> tzfail (Invalid_kind (loc, [Seq_kind], Prim_kind)) | Seq (_, fields) -> ( - let rec find_fields ctxt p s c views fields = + let rec find_fields p s c views fields = match fields with - | [] -> return (ctxt, (p, s, c, views)) + | [] -> return (p, s, c, views) | Int (loc, _) :: _ -> tzfail (Invalid_kind (loc, [Prim_kind], Int_kind)) | String (loc, _) :: _ -> @@ -1964,27 +1965,24 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = tzfail (Invalid_kind (loc, [Prim_kind], Seq_kind)) | Prim (loc, K_parameter, [arg], annot) :: rest -> ( match p with - | None -> find_fields ctxt (Some (arg, loc, annot)) s c views rest + | None -> find_fields (Some (arg, loc, annot)) s c views rest | Some _ -> tzfail (Duplicate_field (loc, K_parameter))) | Prim (loc, K_storage, [arg], annot) :: rest -> ( match s with - | None -> find_fields ctxt p (Some (arg, loc, annot)) c views rest + | None -> find_fields p (Some (arg, loc, annot)) c views rest | Some _ -> tzfail (Duplicate_field (loc, K_storage))) | Prim (loc, K_code, [arg], annot) :: rest -> ( match c with - | None -> find_fields ctxt p s (Some (arg, loc, annot)) views rest + | None -> find_fields p s (Some (arg, loc, annot)) views rest | Some _ -> tzfail (Duplicate_field (loc, K_code))) | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) :: _ -> tzfail (Invalid_arity (loc, name, 1, List.length args)) | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _) :: rest -> - let* str, ctxt = Gas_monad.run ctxt @@ parse_view_name name in - let* str in - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.view_update str views) + let* str = parse_view_name name in + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.view_update str views in if Script_map.mem str views then tzfail (Duplicated_view_name loc) else @@ -1994,15 +1992,15 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = (Some {input_ty; output_ty; view_code}) views in - find_fields ctxt p s c views' rest + find_fields p s c views' rest | Prim (loc, K_view, args, _) :: _ -> tzfail (Invalid_arity (loc, K_view, 4, List.length args)) | Prim (loc, name, _, _) :: _ -> let allowed = [K_parameter; K_storage; K_code; K_view] in tzfail (Invalid_primitive (loc, allowed, name)) in - let* ctxt, toplevel = - find_fields ctxt None None None (Script_map.empty string_t) fields + let* toplevel = + find_fields None None None (Script_map.empty string_t) fields in match toplevel with | None, _, _, _ -> tzfail (Missing_field K_parameter) @@ -2012,10 +2010,10 @@ let parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult = Some (s, sloc, sannot), Some (c, cloc, cannot), views ) -> - let* () = Script_ir_annot.error_unexpected_annot ploc pannot in - let* () = Script_ir_annot.error_unexpected_annot cloc cannot in - let+ () = Script_ir_annot.error_unexpected_annot sloc sannot in - ({code_field = c; arg_type = p; views; storage_type = s}, ctxt)) + let*? () = Script_ir_annot.error_unexpected_annot ploc pannot in + let*? () = Script_ir_annot.error_unexpected_annot cloc cannot in + let+? () = Script_ir_annot.error_unexpected_annot sloc sannot in + {code_field = c; arg_type = p; views; storage_type = s}) (* Normalize lambdas during parsing *) @@ -4353,13 +4351,13 @@ and parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - let*? {arg_type; storage_type; code_field; views}, ctxt = - parse_toplevel ctxt canonical_code - in let*? res, ctxt = Gas_monad.run ctxt @@ let open Gas_monad.Syntax in + let* {arg_type; storage_type; code_field; views} = + parse_toplevel canonical_code + in let error_details = Informative () in let* arg_type = Gas_monad.record_trace_eval ~error_details (fun () -> @@ -4379,10 +4377,12 @@ and parse_instr : ~legacy storage_type in - (arg_type, storage_type) + (arg_type, storage_type, code_field, views) in let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = + Ex_ty storage_type, + code_field, + views ) = res in let*? (Ty_ex_c arg_type_full) = pair_t loc arg_type storage_type in @@ -5019,14 +5019,15 @@ and parse_contract : ctxt code in - (* can only fail because of gas *) - let*? {arg_type; _}, ctxt = parse_toplevel ctxt code in let*? targ, ctxt = Gas_monad.run ctxt - @@ parse_parameter_ty_and_entrypoints - ~stack_depth:(stack_depth + 1) - ~legacy:true - arg_type + @@ + let open Gas_monad.Syntax in + let* {arg_type; _} = parse_toplevel code in + parse_parameter_ty_and_entrypoints + ~stack_depth:(stack_depth + 1) + ~legacy:true + arg_type in let*? (Ex_parameter_ty_and_entrypoints {arg_type = targ; entrypoints}) = @@ -5166,15 +5167,13 @@ let parse_code : in let legacy = elab_conf.legacy in let* ctxt, code = Global_constants_storage.expand ctxt code in - let*? {arg_type; storage_type; code_field; views}, ctxt = - parse_toplevel ctxt code - in - let arg_type_loc = location arg_type in - let storage_type_loc = location storage_type in let*? res, ctxt = Gas_monad.run ctxt @@ let open Gas_monad.Syntax in + let* {arg_type; storage_type; code_field; views} = parse_toplevel code in + let arg_type_loc = location arg_type in + let storage_type_loc = location storage_type in let* arg_type = Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> Ill_formed_type (Some "parameter", code, arg_type_loc)) @@ -5185,10 +5184,13 @@ let parse_code : Ill_formed_type (Some "storage", code, storage_type_loc)) @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type in - (arg_type, storage_type) + (arg_type, storage_type, code_field, views, storage_type_loc) in let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = + Ex_ty storage_type, + code_field, + views, + storage_type_loc ) = res in let*? (Ty_ex_c arg_type_full) = @@ -5305,15 +5307,15 @@ let typecheck_code : fun ~unparse_code_rec ~legacy ~show_types ctxt code -> (* Constants need to be expanded or [parse_toplevel] may fail. *) let* ctxt, code = Global_constants_storage.expand ctxt code in - let*? toplevel, ctxt = parse_toplevel ctxt code in - let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in - let arg_type_loc = location arg_type in - let storage_type_loc = location storage_type in let*? res, ctxt = Gas_monad.run ctxt @@ let open Gas_monad.Syntax in + let* toplevel = parse_toplevel code in + let {arg_type; storage_type; code_field; views} = toplevel in + let arg_type_loc = location arg_type in + let storage_type_loc = location storage_type in let* arg_type = Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> Ill_formed_type (Some "parameter", code, arg_type_loc)) @@ -5324,10 +5326,14 @@ let typecheck_code : Ill_formed_type (Some "storage", code, storage_type_loc)) @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type in - (arg_type, ex_storage_type) + (arg_type, ex_storage_type, toplevel, code_field, views, storage_type_loc) in let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = + Ex_ty storage_type, + toplevel, + code_field, + views, + storage_type_loc ) = res in let*? (Ty_ex_c arg_type_full) = @@ -6044,7 +6050,9 @@ let parse_contract_data context loc arg_ty contract ~entrypoint = let parse_toplevel ctxt toplevel = let open Lwt_result_syntax in let* ctxt, toplevel = Global_constants_storage.expand ctxt toplevel in - Lwt.return @@ parse_toplevel ctxt toplevel + let*? toplevel, ctxt = Gas_monad.run ctxt @@ parse_toplevel toplevel in + let*? toplevel in + return (toplevel, ctxt) let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 -- GitLab