From 45f5e7d90394189f94076c3211de55526fd8f814 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 22:06:35 +0200 Subject: [PATCH 01/12] Proto/Michelson: context-free pack_node --- .../lib_protocol/script_ir_translator.ml | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 4228a16a79bd..268ec31858cc 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -155,13 +155,10 @@ let check_comparable : let t = Script_ir_unparser.serialize_ty_for_error ty in tzfail (Comparable_type_expected (loc, t)) -let pack_node unparsed ctxt = - let bytes = - Data_encoding.( - Binary.to_bytes_exn (tup2 (Fixed.string Plain 1) expr_encoding)) - ("\x05", unparsed) - in - (bytes, ctxt) +let pack_node unparsed = + Data_encoding.( + Binary.to_bytes_exn (tup2 (Fixed.string Plain 1) expr_encoding)) + ("\x05", unparsed) let pack_comparable_data ctxt ty data = let open Lwt_result_syntax in @@ -169,7 +166,7 @@ let pack_comparable_data ctxt ty data = Gas_monad.run ctxt @@ unparse_comparable_data Optimized_legacy ty data in let*? unparsed in - return (pack_node unparsed ctxt) + return (pack_node unparsed, ctxt) let hash_bytes bytes = let open Gas_monad.Syntax in @@ -5551,7 +5548,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage let pack_data_with_mode ctxt ty data ~mode = let open Lwt_result_syntax in let+ unparsed, ctxt = unparse_data ~stack_depth:0 ctxt mode ty data in - pack_node unparsed ctxt + (pack_node unparsed, ctxt) let hash_data ctxt ty data = let open Lwt_result_syntax in -- GitLab From 6d095482238940b74d0f1f5900190979d27d641d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 10:53:59 +0200 Subject: [PATCH 02/12] Expose gas monad version of unparse_data --- devtools/get_contracts/get_contracts_alpha.ml | 9 +- .../interpreter_workload.ml | 7 +- src/proto_alpha/lib_plugin/RPC.ml | 74 ++++++++------ src/proto_alpha/lib_protocol/apply.ml | 13 ++- .../lib_protocol/contract_services.ml | 29 ++++-- src/proto_alpha/lib_protocol/main.ml | 17 ++-- .../sc_rollup_management_protocol.ml | 33 ++++--- .../lib_protocol/script_interpreter.ml | 17 +++- .../lib_protocol/script_interpreter_defs.ml | 97 +++++++++++++------ .../lib_protocol/script_ir_translator.ml | 54 +++++++---- .../lib_protocol/script_ir_translator.mli | 4 +- .../lib_protocol/script_ir_unparser.ml | 14 +-- .../lib_protocol/script_ir_unparser.mli | 8 +- .../lib_protocol/test/helpers/block.ml | 10 +- .../michelson/test_ticket_accounting.ml | 34 ++++--- .../michelson/test_ticket_operations_diff.ml | 15 +-- .../michelson/test_ticket_scanner.ml | 15 +-- .../michelson/test_typechecking.ml | 66 ++++++++----- .../integration/operations/test_sc_rollup.ml | 18 ++-- .../test/pbt/test_script_comparison.ml | 6 +- .../test/unit/test_sc_rollup_arith.ml | 17 ++-- .../lib_protocol/ticket_balance_key.ml | 34 ++++--- .../lib_protocol/ticket_transfer.ml | 7 +- 23 files changed, 377 insertions(+), 221 deletions(-) diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 2033d329029d..a6b63b3b8460 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -150,10 +150,11 @@ module Proto = struct let unparse_data_cost (raw_ctxt : Raw_context.t) ty data = let open Lwt_result_syntax in let ctxt : Alpha_context.context = Obj.magic raw_ctxt in - let+ _expr, updated_ctxt = - Lwt.map wrap_tzresult + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? _expr, updated_ctxt = + wrap_tzresult @@ Gas_monad.run ctxt @@ Script_ir_translator.unparse_data - ctxt + ~elab_conf Script_ir_unparser.Optimized ty data @@ -162,7 +163,7 @@ module Proto = struct (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) in assert (consumed > 0) ; - consumed + return consumed let unparse_ty (_raw_ctxt : Raw_context.t) (Ex_ty ty) = wrap_tzresult @@ Gas_monad.run_unaccounted diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml index c7c16d355f91..261ec6066699 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml @@ -1466,12 +1466,13 @@ let extract_ir_sized_step : Instructions.check_signature_bls pk signature message) | IHash_key (_, _), _ -> Instructions.hash_key | IPack (_, ty, _), (v, _) -> ( + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in let script_res = - Lwt_main.run (Script_ir_translator.unparse_data ctxt Optimized ty v) + Gas_monad.run_unaccounted + (Script_ir_translator.unparse_data ~elab_conf Optimized ty v) in match script_res with - | Ok (node, _ctxt) -> - Instructions.pack (Size.of_micheline (Micheline.root node)) + | Ok node -> Instructions.pack (Size.of_micheline (Micheline.root node)) | Error _ -> Stdlib.failwith "IPack workload: could not unparse") | IUnpack (_, _, _), _ -> Instructions.unpack | IBlake2b (_, _), (bytes, _) -> Instructions.blake2b (Size.bytes bytes) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 20b9a1aea174..75a841e7de24 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -613,18 +613,20 @@ module Scripts = struct let open Lwt_result_syntax in (* We drop the gas limit as this function is only used for debugging/errors. *) let ctxt = Gas.set_unlimited ctxt in + let elab_conf = elab_conf ~legacy:true ctxt in let rec unparse_stack : type a s. (a, s) Script_typed_ir.stack_ty * (a * s) -> Script.expr list tzresult Lwt.t = function | Bot_t, (EmptyCell, EmptyCell) -> return_nil | Item_t (ty, rest_ty), (v, rest) -> - let* data, _ctxt = - Script_ir_translator.unparse_data - ctxt - Unparsing_mode.unparsing_mode - ty - v + let*? data = + Gas_monad.run_unaccounted + @@ Script_ir_translator.unparse_data + ~elab_conf + Unparsing_mode.unparsing_mode + ty + v in let+ rest = unparse_stack (rest_ty, rest) in data :: rest @@ -856,12 +858,18 @@ module Scripts = struct match (sty, x, st) with | Bot_t, EmptyCell, EmptyCell -> return ([], ctxt) | Item_t (ty, sty), x, (y, st) -> - let*? ty_node, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc ty - in - let* data_node, ctxt = - Script_ir_translator.unparse_data ctxt unparsing_mode ty x + let elab_conf = elab_conf ~legacy:true ctxt in + let*? nodes, ctxt = + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* ty_node = Script_ir_unparser.unparse_ty ~loc ty in + let+ data_node = + Script_ir_translator.unparse_data ~elab_conf unparsing_mode ty x + in + (ty_node, data_node) in + let*? ty_node, data_node = nodes in let* l, ctxt = unparse_stack ctxt unparsing_mode sty y st in return ((Micheline.strip_locations ty_node, data_node) :: l, ctxt) end @@ -1697,23 +1705,29 @@ module Scripts = struct (fun ctxt () (expr, typ, unparsing_mode, legacy) -> let open Script_ir_translator in let legacy = Option.value ~default:false legacy in + let elab_conf = elab_conf ~legacy ctxt in let ctxt = Gas.set_unlimited ctxt in let*? (Ex_ty typ) = Gas_monad.run_unaccounted @@ Script_ir_translator.parse_any_ty ~legacy (Micheline.root typ) in - let* data, ctxt = + let* data, _ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy ctxt) + ~elab_conf ~allow_forged:true typ (Micheline.root expr) in - let+ normalized, _ctxt = - Script_ir_translator.unparse_data ctxt unparsing_mode typ data + let*? normalized = + Gas_monad.run_unaccounted + @@ Script_ir_translator.unparse_data + ~elab_conf + unparsing_mode + typ + data in - normalized) ; + return normalized) ; Registration.register0 ~chunked:true S.normalize_stack @@ -2050,18 +2064,16 @@ module Contract = struct | None -> return_none | Some script -> let ctxt = Gas.set_unlimited ctxt in + let elab_conf = elab_conf ~legacy:true ctxt in let open Script_ir_translator in - let* Ex_script (Script {storage; storage_type; _}), ctxt = - parse_script - ctxt - ~elab_conf:(elab_conf ~legacy:true ctxt) - ~allow_forged_in_storage:true - script + let* Ex_script (Script {storage; storage_type; _}), _ctxt = + parse_script ctxt ~elab_conf ~allow_forged_in_storage:true script in - let+ storage, _ctxt = - unparse_data ctxt unparsing_mode storage_type storage + let*? storage = + Gas_monad.run_unaccounted + @@ unparse_data ~elab_conf unparsing_mode storage_type storage in - Some storage) ; + return_some storage) ; (* Patched RPC: get_script *) Registration.register1 ~chunked:true @@ -2239,18 +2251,20 @@ module Big_map = struct match value with | None -> raise Not_found | Some value -> - let* value, ctxt = + let elab_conf = elab_conf ~legacy:true ctxt in + let* value, _ctxt = parse_data ctxt - ~elab_conf:(elab_conf ~legacy:true ctxt) + ~elab_conf ~allow_forged:true value_type (Micheline.root value) in - let+ value, _ctxt = - unparse_data ctxt unparsing_mode value_type value + let*? value = + Gas_monad.run_unaccounted + @@ unparse_data ~elab_conf unparsing_mode value_type value in - value)) + return value)) let big_map_get_normalized ctxt block id key ~unparsing_mode = RPC_context.make_call2 diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 7198bfff63ea..5a2f7b4a1c3c 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -730,9 +730,16 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code ~to_update ~temporary:false in - let* storage, ctxt = - Script_ir_translator.unparse_data ctxt Optimized storage_type storage - in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? storage, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Optimized + storage_type + storage + in + let*? storage in let storage = Script.lazy_expr storage in (* Normalize code to avoid #843 *) let* code, ctxt = diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 4ec4d9eece40..8c4dc9b27db8 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -426,8 +426,14 @@ let register () = value_type (Micheline.root value) in - let+ value, _ctxt = unparse_data ctxt Readable value_type value in - Some value) + let elab_conf = + Script_ir_translator_config.make ~legacy:true ctxt + in + let*? value = + Gas_monad.run_unaccounted + @@ unparse_data ~elab_conf Readable value_type value + in + return_some value) in let do_big_map_get_all ?offset ?length ctxt id = let open Script_ir_translator in @@ -455,8 +461,15 @@ let register () = value_type (Micheline.root value) in - let+ value, ctxt = unparse_data ctxt Readable value_type value in - (ctxt, value :: rev_values)) + let elab_conf = + Script_ir_translator_config.make ~legacy:true ctxt + in + let*? value, ctxt = + Gas_monad.run ctxt + @@ unparse_data ~elab_conf Readable value_type value + in + let*? value in + return (ctxt, value :: rev_values)) (Ok (ctxt, [])) key_values in @@ -527,10 +540,12 @@ let register () = ~allow_forged_in_storage:true script in - let+ storage, _ctxt = - unparse_data ctxt Readable storage_type storage + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? storage = + Gas_monad.run_unaccounted + @@ unparse_data ~elab_conf Readable storage_type storage in - Some storage) ; + return_some storage) ; opt_register2 ~chunked:true S.entrypoint_type diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index 780dc6075e9f..2f5c1565b329 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -388,15 +388,18 @@ let init chain_id ctxt block_header = ~to_update:Script_ir_translator.no_lazy_storage_id ~temporary:false in - let+ storage, ctxt = - Script_ir_translator.unparse_data - ctxt - Optimized - parsed_script.storage_type - storage + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? storage, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Optimized + parsed_script.storage_type + storage in + let*? storage in let storage = Alpha_context.Script.lazy_expr storage in - (({script with storage}, lazy_storage_diff), ctxt) + return (({script with storage}, lazy_storage_diff), ctxt) in (* The cache must be synced at the end of block validation, so we do so here for the first block in a protocol where `finalize_block` 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 7d1ab001044c..6b741092937f 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -58,16 +58,20 @@ type outbox_message = let make_internal_transfer ctxt ty ~payload ~sender ~source ~destination = let open Lwt_result_syntax in - let+ payload, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized - ty - payload + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? payload, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Optimized + ty + payload in - ( Sc_rollup.Inbox_message.Internal - (Transfer {payload; sender; source; destination}), - ctxt ) + let*? payload in + return + ( Sc_rollup.Inbox_message.Internal + (Transfer {payload; sender; source; destination}), + ctxt ) let make_transaction ctxt ~parameters_ty ~unparsed_parameters ~destination ~entrypoint = @@ -153,9 +157,16 @@ let outbox_message_of_outbox_message_repr ctxt transactions = module Internal_for_tests = struct let make_transaction ctxt parameters_ty ~parameters ~destination ~entrypoint = let open Lwt_result_syntax in - let* unparsed_parameters, ctxt = - Script_ir_translator.unparse_data ctxt Optimized parameters_ty parameters + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? unparsed_parameters, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Optimized + parameters_ty + parameters in + let*? unparsed_parameters in return ( Transaction { diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 7904f66eeebe..b2d8a72e9d39 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -517,9 +517,13 @@ module Raw = struct (fun logger (ctxt, _) gas kloc tv accu -> let v = accu in let ctxt = update_context gas ctxt in - let* v, _ctxt = - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? v, _ctxt = + record_trace Cannot_serialize_failure + @@ Gas_monad.run ctxt + @@ unparse_data ~elab_conf Optimized tv v in + let*? v = record_trace Cannot_serialize_failure v in let* log = get_log logger in tzfail (Reject (kloc, v, log))); } @@ -1867,8 +1871,13 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal storage_type new_storage in - let* unparsed_storage, ctxt = - trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage) + let*? unparsed_storage, ctxt = + record_trace Cannot_serialize_storage + @@ Gas_monad.run ctxt + @@ unparse_data ~elab_conf mode storage_type storage + in + let*? unparsed_storage = + record_trace Cannot_serialize_storage unparsed_storage in let op_to_couple op = (op.piop, op.lazy_storage_diff) in let operations, op_diffs = diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index c0c9fa743978..0807fd00b446 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -479,10 +479,16 @@ let apply ctxt gas capture_ty capture lam = let open Lwt_result_syntax in let loc = Micheline.dummy_location in let ctxt = update_context gas ctxt in - let*? ty_expr, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc capture_ty + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? typed_const_expr, ctxt = + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* ty = Script_ir_unparser.unparse_ty ~loc capture_ty in + let+ const = unparse_data ~elab_conf Optimized capture_ty capture in + (ty, const) in - let* const_expr, ctxt = unparse_data ctxt Optimized capture_ty capture in + let*? ty_expr, const_expr = typed_const_expr in let make_expr expr = Micheline.( Seq @@ -584,12 +590,22 @@ let make_transaction_to_sc_rollup ctxt ~destination ~amount ~entrypoint let*? () = error_unless (Entrypoint.is_default entrypoint) Rollup_invalid_entrypoint in - let+ unparsed_parameters, ctxt = - unparse_data ctxt Optimized parameters_ty parameters + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? unparsed_parameters, ctxt = + Gas_monad.run ctxt + @@ unparse_data ~elab_conf Optimized parameters_ty parameters in - ( Transaction_to_sc_rollup - {destination; entrypoint; parameters_ty; parameters; unparsed_parameters}, - ctxt ) + let*? unparsed_parameters in + return + ( Transaction_to_sc_rollup + { + destination; + entrypoint; + parameters_ty; + parameters; + unparsed_parameters; + }, + ctxt ) (** [emit_event] generates an internal operation that will effect an event emission if the contract code returns this successfully. *) @@ -599,9 +615,12 @@ let emit_event (type t tc) (ctxt, sc) gas ~(event_type : (t, tc) ty) let ctxt = update_context gas ctxt in (* No need to take care of lazy storage as only packable types are allowed *) let lazy_storage_diff = None in - let* unparsed_data, ctxt = - unparse_data ctxt Optimized event_type event_data + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? unparsed_data, ctxt = + Gas_monad.run ctxt + @@ unparse_data ~elab_conf Optimized event_type event_data in + let*? unparsed_data in let*? ctxt, nonce = fresh_internal_nonce ctxt in let operation = Event {ty = unparsed_ty; tag; unparsed_data} in let iop = @@ -621,12 +640,16 @@ let make_transaction_to_zk_rollup (type t) ctxt ~destination ~amount let*? () = error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount in - let+ unparsed_parameters, ctxt = - unparse_data ctxt Optimized parameters_ty parameters + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? unparsed_parameters, ctxt = + Gas_monad.run ctxt + @@ unparse_data ~elab_conf Optimized parameters_ty parameters in - ( Transaction_to_zk_rollup - {destination; parameters_ty; parameters; unparsed_parameters}, - ctxt ) + let*? unparsed_parameters in + return + ( Transaction_to_zk_rollup + {destination; parameters_ty; parameters; unparsed_parameters}, + ctxt ) (* [transfer (ctxt, sc) gas tez parameters_ty parameters destination entrypoint] creates an operation that transfers an amount of [tez] to a destination and @@ -636,15 +659,18 @@ let transfer (type t) (ctxt, sc) gas amount location (typed_contract : t typed_contract) (parameters : t) = let open Lwt_result_syntax in let ctxt = update_context gas ctxt in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in let* operation, lazy_storage_diff, ctxt = match typed_contract with | Typed_implicit destination -> let () = parameters in return (Transaction_to_implicit {destination; amount}, None, ctxt) | Typed_implicit_with_ticket {destination; ticket_ty} -> - let* unparsed_ticket, ctxt = - unparse_data ctxt Optimized ticket_ty parameters + let*? unparsed_ticket, ctxt = + Gas_monad.run ctxt + @@ unparse_data ~elab_conf Optimized ticket_ty parameters in + let*? unparsed_ticket in return ( Transaction_to_implicit_with_ticket { @@ -672,21 +698,24 @@ let transfer (type t) (ctxt, sc) gas amount location ~to_update ~temporary:true in - let+ unparsed_parameters, ctxt = - unparse_data ctxt Optimized parameters_ty parameters + let*? unparsed_parameters, ctxt = + Gas_monad.run ctxt + @@ unparse_data ~elab_conf Optimized parameters_ty parameters in - ( Transaction_to_smart_contract - { - destination; - amount; - entrypoint; - location; - parameters_ty; - parameters; - unparsed_parameters; - }, - lazy_storage_diff, - ctxt ) + let*? unparsed_parameters in + return + ( Transaction_to_smart_contract + { + destination; + amount; + entrypoint; + location; + parameters_ty; + parameters; + unparsed_parameters; + }, + lazy_storage_diff, + ctxt ) | Typed_sc_rollup {arg_ty = parameters_ty; sc_rollup = destination; entrypoint} -> let+ operation, ctxt = @@ -741,7 +770,11 @@ let create_contract (ctxt, sc) gas storage_type code delegate credit init = ~to_update ~temporary:true in - let* unparsed_storage, ctxt = unparse_data ctxt Optimized storage_type init in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? unparsed_storage, ctxt = + Gas_monad.run ctxt @@ unparse_data ~elab_conf Optimized storage_type init + in + let*? unparsed_storage in let*? ctxt, preorigination = Contract.fresh_contract_from_current_nonce ctxt in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 268ec31858cc..86145613f3c4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5465,12 +5465,15 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage storage_type ~storage in - let*? code = + let*? code, storage = Gas_monad.run_unaccounted - @@ unparse_code ~stack_depth:0 ~elab_conf mode code_field - in - let* storage, ctxt = - unparse_data ctxt ~stack_depth:0 mode storage_type storage + @@ + let open Gas_monad.Syntax in + let* code = unparse_code ~stack_depth:0 ~elab_conf mode code_field in + let+ storage = + unparse_data ~stack_depth:0 ~elab_conf mode storage_type storage + in + (code, storage) in let loc = Micheline.dummy_location in let* arg_type, storage_type, views, ctxt = @@ -5547,8 +5550,12 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage let pack_data_with_mode ctxt ty data ~mode = let open Lwt_result_syntax in - let+ unparsed, ctxt = unparse_data ~stack_depth:0 ctxt mode ty data in - (pack_node unparsed, ctxt) + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? unparsed, ctxt = + Gas_monad.run ctxt @@ unparse_data ~stack_depth:0 ~elab_conf mode ty data + in + let*? unparsed in + return (pack_node unparsed, ctxt) let hash_data ctxt ty data = let open Lwt_result_syntax in @@ -5605,21 +5612,26 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy List.fold_left_es (fun (acc, ctxt) (key_hash, key, value) -> let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in - let*? key, ctxt = - Gas_monad.run ctxt @@ unparse_comparable_data mode key_type key - in - let*? key in - let+ value, ctxt = - match value with - | None -> return (None, ctxt) - | Some x -> - let+ node, ctxt = - unparse_data ~stack_depth:0 ctxt mode value_type x - in - (Some node, ctxt) + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? key_value, ctxt = + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* key = unparse_comparable_data mode key_type key in + let+ value = + match value with + | None -> return None + | Some x -> + let+ node = + unparse_data ~stack_depth:0 ~elab_conf mode value_type x + in + Some node + in + (key, value) in + let*? key, value = key_value in let diff_item = Big_map.{key; key_hash; value} in - (diff_item :: acc, ctxt)) + return (diff_item :: acc, ctxt)) ([], ctxt) (List.rev pairs) in @@ -6067,7 +6079,7 @@ let parse_packable_data ~elab_conf ty t = ty t -let unparse_data = unparse_data ~stack_depth:0 +let unparse_data ~elab_conf = unparse_data ~stack_depth:0 ~elab_conf let unparse_code ctxt mode code = let open Lwt_result_syntax in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index b31bb351dff4..52f0fc7dc4fc 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -194,11 +194,11 @@ val parse_packable_data : (* Unparsing an IR-typed data back into a Micheline node data *) val unparse_data : - context -> + elab_conf:Script_ir_translator_config.elab_config -> Script_ir_unparser.unparsing_mode -> ('a, _) Script_typed_ir.ty -> 'a -> - (Script.expr * context) tzresult Lwt.t + (Script.expr, error trace) Gas_monad.t val unparse_code : context -> diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index a329b9df4cd7..70e36e704b5c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -776,16 +776,10 @@ module Data_unparser (P : MICHELSON_PARSER) = struct return (Prim (loc, prim, List.rev items, annot)) | (Int _ | String _ | Bytes _) as atom -> return atom - let unparse_data ctxt ~stack_depth mode ty v = - let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in - let*? unparsed_data, ctxt = - Gas_monad.run ctxt @@ unparse_data_rec ~stack_depth mode ~elab_conf ty v - in - let*? unparsed_data in - Lwt.return - (Gas_monad.run_pure ctxt - @@ account_for_future_serialization_cost unparsed_data) + let unparse_data ~stack_depth ~elab_conf mode ty v = + let open Gas_monad.Syntax in + let* unparsed_data = unparse_data_rec ~stack_depth mode ~elab_conf ty v in + account_for_future_serialization_cost unparsed_data let unparse_code ~stack_depth ~elab_conf mode v = let open Gas_monad.Syntax in diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index ca2537ddac56..815fc47977f6 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -183,16 +183,16 @@ module type MICHELSON_PARSER = sig end module Data_unparser : functor (P : MICHELSON_PARSER) -> sig - (** [unparse_data ctxt ~stack_depth unparsing_mode ty data] returns the + (** [unparse_data ~stack_depth unparsing_mode ty data] returns the Micheline representation of [data] of type [ty], consuming an appropriate - amount of gas from [ctxt]. *) + amount of gas. *) val unparse_data : - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> ('a, 'ac) ty -> 'a -> - (Script.expr * context) tzresult Lwt.t + (Script.expr, error trace) Gas_monad.t (** [unparse_items ctxt ~stack_depth unparsing_mode kty vty assoc] returns the Micheline representation of [assoc] (being an association list) with keys diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 381559722241..b9a9dab2c8c0 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -461,15 +461,17 @@ let initial_alpha_context ?(commitments = []) constants ~to_update:Script_ir_translator.no_lazy_storage_id ~temporary:false in - let+ storage, ctxt = - Script_ir_translator.unparse_data - ctxt + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? storage, ctxt = + Gas_monad.run ctxt @@ + Script_ir_translator.unparse_data ~elab_conf Optimized parsed_script.storage_type storage in + let*? storage in let storage = Alpha_context.Script.lazy_expr storage in - (({script with storage}, lazy_storage_diff), ctxt) + return (({script with storage}, lazy_storage_diff), ctxt) in let*@ result = Alpha_context.prepare_first_block 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 f44d6aa9405c..c63cf3f0052b 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 @@ -156,13 +156,18 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = match value with | None -> return (None, ctxt) | Some value -> - let*@ value_node, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - value_type - value + let elab_conf = + Script_ir_translator_config.make ~legacy:true ctxt in + let*?@ value_node, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Readable + value_type + value + in + let*?@ value_node in return (Some value_node, ctxt) in return ({Big_map.key; key_hash; value} :: kvs, ctxt)) @@ -394,13 +399,16 @@ let originate block ~sender ~baker ~script ~storage ~forges_tickets = let transfer_operation ctxt ~sender ~destination ~arg_type ~arg = let open Lwt_result_wrap_syntax in - let*@ params_node, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - arg_type - arg - in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*?@ params_node, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Readable + arg_type + arg + in + let*?@ params_node in return ( Internal_operation { 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 56bacc5f3198..09650cf81ad2 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 @@ -319,13 +319,16 @@ let originate block ~sender ~baker ~script ~storage ~forges_tickets = let transfer_operation ~incr ~sender ~destination ~parameters_ty ~parameters = let open Lwt_result_wrap_syntax in let ctxt = Incremental.alpha_ctxt incr in - let*@ params_node, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - parameters_ty - parameters + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*?@ params_node, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Readable + parameters_ty + parameters in + let*?@ params_node in let incr = Incremental.set_alpha_ctxt incr ctxt in return ( Script_typed_ir.Internal_operation 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 45f86bf97f10..8ecf7513625b 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 @@ -70,13 +70,16 @@ let string_list_of_ex_tickets ctxt tickets = let accum (xs, ctxt) (Ticket_scanner.Ex_ticket (cty, {Script_typed_ir.ticketer; contents; amount})) = - let*@ x, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Readable - cty - contents + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*?@ x, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Readable + cty + contents in + let*?@ x in let content = Format.kasprintf Fun.id "%a" Michelson_v1_printer.print_expr x in 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 f6b7e74a3205..354fa83bdaa0 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 @@ -641,21 +641,32 @@ let test_parse_address () = in () -let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = +let test_unparse_data loc ~elab_conf ty x ~expected_readable ~expected_optimized + = let open Lwt_result_wrap_syntax in - let*@ actual_readable, ctxt = - Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x + let*?@ actual_readable = + Gas_monad.run_unaccounted + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Readable + ty + x in - let*@ ctxt = + let* () = if actual_readable = Micheline.strip_locations expected_readable then - return ctxt + return_unit else Alcotest.failf "Error in readable unparsing: %s" loc in - let*@ actual_optimized, ctxt = - Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x + let*?@ actual_optimized = + Gas_monad.run_unaccounted + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Optimized + ty + x in if actual_optimized = Micheline.strip_locations expected_optimized then - return ctxt + return_unit else Alcotest.failf "Error in optimized unparsing: %s" loc let test_unparse_comb_data () = @@ -671,11 +682,12 @@ let test_unparse_comb_data () = let pair_prim2 a b = pair_prim [a; b] in let pair_z_z_prim = pair_prim2 z_prim z_prim in let* ctxt = test_context () in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in (* Pair 0 0 *) - let* ctxt = + let* () = test_unparse_data __LOC__ - ctxt + ~elab_conf pair_nat_nat_ty (z, z) ~expected_readable:pair_z_z_prim @@ -683,10 +695,10 @@ let test_unparse_comb_data () = in (* Pair (Pair 0 0) 0 *) let*?@ (Ty_ex_c pair_pair_nat_nat_nat_ty) = pair_ty pair_nat_nat_ty nat_ty in - let* ctxt = + let* () = test_unparse_data __LOC__ - ctxt + ~elab_conf pair_pair_nat_nat_nat_ty ((z, z), z) ~expected_readable:(pair_prim2 pair_z_z_prim z_prim) @@ -694,10 +706,10 @@ let test_unparse_comb_data () = in (* Readable: Pair 0 0 0; Optimized: Pair 0 (Pair 0 0) *) let*?@ (Ty_ex_c pair_nat_pair_nat_nat_ty) = pair_ty nat_ty pair_nat_nat_ty in - let* ctxt = + let* () = test_unparse_data __LOC__ - ctxt + ~elab_conf pair_nat_pair_nat_nat_ty (z, (z, z)) ~expected_readable:(pair_prim [z_prim; z_prim; z_prim]) @@ -707,10 +719,10 @@ let test_unparse_comb_data () = let*?@ (Ty_ex_c pair_nat_pair_nat_pair_nat_nat_ty) = pair_ty nat_ty pair_nat_pair_nat_nat_ty in - let* (_ : context) = + let* () = test_unparse_data __LOC__ - ctxt + ~elab_conf pair_nat_pair_nat_pair_nat_nat_ty (z, (z, (z, z))) ~expected_readable:(pair_prim [z_prim; z_prim; z_prim; z_prim]) @@ -750,9 +762,14 @@ let test_optimal_comb () = Bytes.length @@ Data_encoding.Binary.to_bytes_exn Script.expr_encoding canonical ) in - let check_optimal_comb loc ctxt ty v arity = - let*@ unparsed, ctxt = - Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty v + let check_optimal_comb loc ~elab_conf ty v arity = + let*?@ unparsed = + Gas_monad.run_unaccounted + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Optimized + ty + v in let unparsed_canonical, unparsed_size = size_of_micheline (Micheline.root unparsed) @@ -778,22 +795,23 @@ let test_optimal_comb () = else return_unit) @@ gen_combs leaf_mich arity in - return ctxt + return_unit in let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in let* ctxt = test_context () in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in let*?@ (Ty_ex_c comb2_ty) = pair_ty leaf_ty leaf_ty in let comb2_v = (leaf_v, leaf_v) in - let* ctxt = check_optimal_comb __LOC__ ctxt comb2_ty comb2_v 2 in + let* () = check_optimal_comb __LOC__ ~elab_conf comb2_ty comb2_v 2 in let*?@ (Ty_ex_c comb3_ty) = pair_ty leaf_ty comb2_ty in let comb3_v = (leaf_v, comb2_v) in - let* ctxt = check_optimal_comb __LOC__ ctxt comb3_ty comb3_v 3 in + let* () = check_optimal_comb __LOC__ ~elab_conf comb3_ty comb3_v 3 in let*?@ (Ty_ex_c comb4_ty) = pair_ty leaf_ty comb3_ty in let comb4_v = (leaf_v, comb3_v) in - let* ctxt = check_optimal_comb __LOC__ ctxt comb4_ty comb4_v 4 in + let* () = check_optimal_comb __LOC__ ~elab_conf comb4_ty comb4_v 4 in let*?@ (Ty_ex_c comb5_ty) = pair_ty leaf_ty comb4_ty in let comb5_v = (leaf_v, comb4_v) in - let* (_ : context) = check_optimal_comb __LOC__ ctxt comb5_ty comb5_v 5 in + let* () = check_optimal_comb __LOC__ ~elab_conf comb5_ty comb5_v 5 in return_unit let gas_monad_run ctxt m = 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 0bbb73d6ceee..fbcbfc8ddefb 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 @@ -348,17 +348,18 @@ let publish_op_and_dummy_commitment ~sender ?compressed_state ?predecessor let verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters = let open Lwt_result_wrap_syntax in let show exp = Expr.to_string @@ exp in - let unparse ctxt parameters = + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let unparse parameters = Script_ir_translator.unparse_data - ctxt + ~elab_conf Script_ir_unparser.Optimized parameters_ty parameters in - let*@ unparsed_parameters, ctxt = + let*@ unparsed_parameters = (* Make sure we can parse the unparsed-parameters with the given parameters type. *) - let* parsed_unparsed_parameters, ctxt = + let* parsed_unparsed_parameters, _ctxt = Script_ir_translator.parse_data ctxt ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) @@ -367,10 +368,15 @@ let verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters = (Environment.Micheline.root unparsed_parameters) in (* Un-parse again to get back to Micheline. *) - unparse ctxt parsed_unparsed_parameters + let*? unparsed_parameters = + Gas_monad.run_unaccounted @@ unparse parsed_unparsed_parameters + in + return unparsed_parameters in (* Un-parse the parsed parameters. *) - let*@ expected_unparsed_parameters, _ctxt = unparse ctxt parameters in + let*?@ expected_unparsed_parameters = + Gas_monad.run_unaccounted @@ unparse parameters + in (* Verify that both version match. *) Assert.equal_string ~loc:__LOC__ diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index 9ad7bcdc6617..d6dba734d05f 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -197,6 +197,8 @@ let ctxt = let* v = Incremental.begin_construction b in return (Incremental.alpha_ctxt v)) +let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt + let unparse_comparable_ty ty = Micheline.strip_locations (fst @@ -204,7 +206,9 @@ let unparse_comparable_ty ty = (Gas_monad.run_pure ctxt Script_ir_unparser.(unparse_ty ~loc:() ty)))) let unparse_comparable_data ty x = - fst (assert_return Script_ir_translator.(unparse_data ctxt Readable ty x)) + assert_ok + (Gas_monad.run_unaccounted + Script_ir_translator.(unparse_data ~elab_conf Readable ty x)) let pack_comparable_data ty x = fst (assert_return Script_ir_translator.(pack_data ctxt ty x)) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml index 9debffcb7751..c3e4c00a5fb3 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_arith.ml @@ -566,13 +566,14 @@ let test_initial_state_hash_arith_pvm () = hash let dummy_internal_transfer address = - let open Lwt_result_syntax in + let open Lwt_result_wrap_syntax in let open Alpha_context.Sc_rollup in let* ctxt = let* block, _baker, _contract, _src2 = Contract_helpers.init () in let+ incr = Incremental.begin_construction block in Incremental.alpha_ctxt incr in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in let sender = Contract_hash.of_b58check_exn "KT1BuEZtb68c1Q4yjtckcNjGELqWt56Xyesc" in @@ -583,14 +584,14 @@ let dummy_internal_transfer address = "tz1RjtZUVeLhADFHDL8UwDZA6vjWWhojpu5w") in let payload = Bytes.of_string "foo" in - let*! result = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized - Bytes_t - payload + let*?@ payload = + Gas_monad.run_unaccounted + @@ Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Optimized + Bytes_t + payload in - let*? payload, _ctxt = Environment.wrap_tzresult result in let transfer = Inbox_message.Internal (Transfer {payload; sender; source; destination = address}) diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index ab41b37c8b5e..be186d1b5625 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -35,20 +35,28 @@ let make ctxt ~owner ~ticketer ~contents_type ~contents = let owner_address = Script_typed_ir.{destination = owner; entrypoint = Entrypoint.default} in - let* ticketer, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized_legacy - Script_typed_ir.address_t - ticketer_address - in - let* owner, ctxt = - Script_ir_translator.unparse_data - ctxt - Script_ir_unparser.Optimized_legacy - Script_typed_ir.address_t - owner_address + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? ticketer_and_owner, ctxt = + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* ticketer = + Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Optimized_legacy + Script_typed_ir.address_t + ticketer_address + in + let+ owner = + Script_ir_translator.unparse_data + ~elab_conf + Script_ir_unparser.Optimized_legacy + Script_typed_ir.address_t + owner_address + in + (ticketer, owner) in + let*? ticketer, owner = ticketer_and_owner in Lwt.return @@ Ticket_hash.make ctxt diff --git a/src/proto_alpha/lib_protocol/ticket_transfer.ml b/src/proto_alpha/lib_protocol/ticket_transfer.ml index 8aa3b8a45d0d..6ba9e0d1b365 100644 --- a/src/proto_alpha/lib_protocol/ticket_transfer.ml +++ b/src/proto_alpha/lib_protocol/ticket_transfer.ml @@ -60,9 +60,12 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents Script_typed_ir.ticket_t Micheline.dummy_location contents_type in let ticket = Script_typed_ir.{ticketer; contents; amount} in - let* unparsed_parameters, ctxt = - Script_ir_translator.unparse_data ctxt Optimized ticket_ty ticket + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? unparsed_parameters, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.unparse_data ~elab_conf Optimized ticket_ty ticket in + let*? unparsed_parameters in let*? ctxt, nonce = fresh_internal_nonce ctxt in let op = Script_typed_ir.Internal_operation -- GitLab From bcfbd5132285e1ce94b65cedb1f4f1c35d0ba574 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 10:57:54 +0200 Subject: [PATCH 03/12] Remove dead "unparse_items" function --- .../lib_protocol/script_ir_unparser.ml | 22 ------------------- .../lib_protocol/script_ir_unparser.mli | 13 ----------- 2 files changed, 35 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 70e36e704b5c..9619ebceb8b7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -786,28 +786,6 @@ module Data_unparser (P : MICHELSON_PARSER) = struct let* unparsed_data = unparse_code_rec ~stack_depth ~elab_conf mode v in account_for_future_serialization_cost unparsed_data - let unparse_items ctxt ~stack_depth mode ty vty vs = - let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in - let*? unparsed_datas, ctxt = - Gas_monad.run ctxt - @@ unparse_items_rec ~stack_depth ~elab_conf mode ty vty vs - in - let*? unparsed_datas in - let*? unparsed_datas, ctxt = - List.fold_left_e - (fun (acc, ctxt) unparsed_data -> - let open Result_syntax in - let+ unparsed_data, ctxt = - Gas_monad.run_pure ctxt - @@ account_for_future_serialization_cost unparsed_data - in - (unparsed_data :: acc, ctxt)) - ([], ctxt) - unparsed_datas - in - return (List.rev unparsed_datas, ctxt) - module Internal_for_benchmarking = struct let unparse_data = unparse_data_rec diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 815fc47977f6..4254437a20ab 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -194,19 +194,6 @@ module Data_unparser : functor (P : MICHELSON_PARSER) -> sig 'a -> (Script.expr, error trace) Gas_monad.t - (** [unparse_items ctxt ~stack_depth unparsing_mode kty vty assoc] returns the - Micheline representation of [assoc] (being an association list) with keys - of type [kty] and values of type [vty]. Gas is being consumed from - [ctxt]. *) - val unparse_items : - context -> - stack_depth:int -> - unparsing_mode -> - 'k comparable_ty -> - ('v, 'vc) ty -> - ('k * 'v) list -> - (Script.expr list * context) tzresult Lwt.t - (** [unparse_code ~stack_depth ~elab_conf unparsing_mode code] returns [code] with [I_PUSH] instructions parsed and unparsed back to make sure that only forgeable values are being pushed. Gas is being consumed. *) -- GitLab From fb77e8720fe7409fe35ebfeffee5f72d40a703a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 11:01:30 +0200 Subject: [PATCH 04/12] move pack_comparable_ty to the gas monad --- .../lib_protocol/script_ir_translator.ml | 22 +++++++++++-------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 86145613f3c4..f3ee5b06e0b4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -160,13 +160,10 @@ let pack_node unparsed = Binary.to_bytes_exn (tup2 (Fixed.string Plain 1) expr_encoding)) ("\x05", unparsed) -let pack_comparable_data ctxt ty data = - let open Lwt_result_syntax in - let*? unparsed, ctxt = - Gas_monad.run ctxt @@ unparse_comparable_data Optimized_legacy ty data - in - let*? unparsed in - return (pack_node unparsed, ctxt) +let pack_comparable_data ty data = + let open Gas_monad.Syntax in + let+ unparsed = unparse_comparable_data Optimized_legacy ty data in + pack_node unparsed let hash_bytes bytes = let open Gas_monad.Syntax in @@ -175,8 +172,15 @@ let hash_bytes bytes = let hash_comparable_data ctxt ty data = let open Lwt_result_syntax in - let* bytes, ctxt = pack_comparable_data ctxt ty data in - Lwt.return @@ Gas_monad.run_pure ctxt @@ hash_bytes bytes + let*? hash, ctxt = + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* bytes = pack_comparable_data ty data in + hash_bytes bytes + in + let*? hash in + return (hash, ctxt) (* ---- Tickets ------------------------------------------------------------ *) -- GitLab From cec1d3c5e64699e60e0bcb6c5b4d5563b6942789 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 11:11:32 +0200 Subject: [PATCH 05/12] hash_comparable_data in gas monad --- .../lib_protocol/contract_services.ml | 5 ++-- .../lib_protocol/script_big_map.ml | 20 +++++++++++--- .../lib_protocol/script_ir_translator.ml | 27 +++++-------------- .../lib_protocol/script_ir_translator.mli | 3 +-- .../michelson/test_ticket_accounting.ml | 23 +++++++++------- .../test_ticket_lazy_storage_diff.ml | 11 ++++---- .../michelson/test_ticket_operations_diff.ml | 11 ++++---- .../michelson/test_ticket_scanner.ml | 11 ++++---- 8 files changed, 59 insertions(+), 52 deletions(-) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 8c4dc9b27db8..e3bea32cb9cd 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -663,8 +663,9 @@ let register () = key_type (Micheline.root key) in - let* key, ctxt = - Script_ir_translator.hash_comparable_data ctxt key_type key + let*? key = + Gas_monad.run_unaccounted + @@ Script_ir_translator.hash_comparable_data key_type key in match script with | None -> return_none diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index 5d1dd2b499c4..e8d8fcfa8083 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -40,7 +40,10 @@ let empty key_type value_type = let mem ctxt key (Big_map {id; diff; key_type; _}) = let open Lwt_result_syntax in - let* key_hash, ctxt = hash_comparable_data ctxt key_type key in + let*? key_hash, ctxt = + Gas_monad.run ctxt @@ hash_comparable_data key_type key + in + let*? key_hash in match (Big_map_overlay.find key_hash diff.map, id) with | None, None -> return (false, ctxt) | None, Some id -> @@ -71,7 +74,10 @@ let get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = let get ctxt key (Big_map {key_type; _} as map) = let open Lwt_result_syntax in - let* key_hash, ctxt = hash_comparable_data ctxt key_type key in + let*? key_hash, ctxt = + Gas_monad.run ctxt @@ hash_comparable_data key_type key + in + let*? key_hash in get_by_hash ctxt key_hash map let update_by_hash key_hash key value (Big_map map) = @@ -88,13 +94,19 @@ let update_by_hash key_hash key value (Big_map map) = let update ctxt key value (Big_map {key_type; _} as map) = let open Lwt_result_syntax in - let* key_hash, ctxt = hash_comparable_data ctxt key_type key in + let*? key_hash, ctxt = + Gas_monad.run ctxt @@ hash_comparable_data key_type key + in + let*? key_hash in let map = update_by_hash key_hash key value map in return (map, ctxt) let get_and_update ctxt key value (Big_map {key_type; _} as map) = let open Lwt_result_syntax in - let* key_hash, ctxt = hash_comparable_data ctxt key_type key in + let*? key_hash, ctxt = + Gas_monad.run ctxt @@ hash_comparable_data key_type key + in + let*? key_hash in let new_map = update_by_hash key_hash key value map in let* old_value, ctxt = get_by_hash ctxt key_hash map in return ((old_value, new_map), ctxt) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f3ee5b06e0b4..67d9f49cd363 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -170,17 +170,10 @@ let hash_bytes bytes = let+$ () = Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes in Script_expr_hash.(hash_bytes [bytes]) -let hash_comparable_data ctxt ty data = - let open Lwt_result_syntax in - let*? hash, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* bytes = pack_comparable_data ty data in - hash_bytes bytes - in - let*? hash in - return (hash, ctxt) +let hash_comparable_data ty data = + let open Gas_monad.Syntax in + let* bytes = pack_comparable_data ty data in + hash_bytes bytes (* ---- Tickets ------------------------------------------------------------ *) @@ -4474,9 +4467,6 @@ module type GAS_MONAD = sig entrypoint:Entrypoint.t -> ('arg typed_contract, error trace) t - val hash_comparable_data : - 'a comparable_ty -> 'a -> (Script_expr_hash.t, error trace) t - val big_map_exists : Big_map.Id.t -> ((expr * expr) option, error trace) t val sapling_state_from_id : Sapling.Id.t -> (Sapling.state, error trace) t @@ -4505,9 +4495,6 @@ struct let parse_contract_data ~stack_depth:_ _loc _ty _dest ~entrypoint:_ = assert false - (* Only used to parse the "big_map" type, which is not packable *) - let hash_comparable_data _ty _x = assert false - (* Only used to parse the "big_map" type, which is not packable *) let big_map_exists _id = assert false @@ -4573,8 +4560,6 @@ struct in (res, ctxt) - let hash_comparable_data ty x ctxt = hash_comparable_data ctxt ty x - let big_map_exists id ctxt = let open Lwt_result_syntax in let+ ctxt, res = Big_map.exists ctxt id in @@ -4796,7 +4781,9 @@ module Data_parser (M : GAS_MONAD) = struct else error_unexpected_annot loc annot in let* k = non_terminal_recursion key_type k in - let* key_hash = hash_comparable_data key_type k in + let* key_hash = + from_gas_monad @@ hash_comparable_data key_type k + in let* v = non_terminal_recursion value_type v in let* () = match last_key with diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 52f0fc7dc4fc..7228270839b0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -417,10 +417,9 @@ val pack_data : (bytes * context) tzresult Lwt.t val hash_comparable_data : - context -> 'a Script_typed_ir.comparable_ty -> 'a -> - (Script_expr_hash.t * context) tzresult Lwt.t + (Script_expr_hash.t, error trace) Gas_monad.t val hash_data : context -> 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 c63cf3f0052b..b673c6fa1aa3 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 @@ -141,17 +141,22 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = let open Lwt_result_wrap_syntax in List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data ctxt key_type key - in - let*?@ key, ctxt = + let*?@ key_hash_and_key, ctxt = Gas_monad.run ctxt - @@ Script_ir_unparser.unparse_comparable_data - Script_ir_unparser.Readable - key_type - key + @@ + let open Gas_monad.Syntax in + let* key_hash = + Script_ir_translator.hash_comparable_data key_type key + in + let+ key = + Script_ir_unparser.unparse_comparable_data + Script_ir_unparser.Readable + key_type + key + in + (key_hash, key) in - let*?@ key in + let*?@ key_hash, key = key_hash_and_key in let* value, ctxt = match value with | None -> return (None, ctxt) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml index 08b3847c6a67..1e825c7ac000 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml @@ -107,12 +107,13 @@ let updates_of_key_values ctxt key_values = let open Lwt_result_wrap_syntax in List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data - ctxt - Script_typed_ir.int_t - (Script_int.of_int key) + let*?@ key_hash, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.hash_comparable_data + Script_typed_ir.int_t + (Script_int.of_int key) in + let*?@ key_hash in return ( { Big_map.key = Expr.from_string @@ string_of_int key; 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 09650cf81ad2..89241ef212b0 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 @@ -74,12 +74,13 @@ let big_map_updates_of_key_values ctxt key_values = let open Lwt_result_wrap_syntax in List.fold_right_es (fun (key, value) (kvs, ctxt) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data - ctxt - Script_typed_ir.int_t - (Script_int.of_int key) + let*?@ key_hash, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.hash_comparable_data + Script_typed_ir.int_t + (Script_int.of_int key) in + let*?@ key_hash in return ( { Big_map.key = Expr.from_string @@ string_of_int key; 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 8ecf7513625b..0218e6970c31 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 @@ -202,12 +202,13 @@ let tickets_from_big_map_ref ~pre_populated value_exp = let* updates, ctxt = List.fold_left_es (fun (kvs, ctxt) (key, value) -> - let*@ key_hash, ctxt = - Script_ir_translator.hash_comparable_data - ctxt - Script_typed_ir.int_t - (Script_int.of_int key) + let*?@ key_hash, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.hash_comparable_data + Script_typed_ir.int_t + (Script_int.of_int key) in + let*?@ key_hash in return ( { Big_map.key = Expr.from_string @@ string_of_int key; -- GitLab From b6b3cd6ed9935c479d6d780facd92e3bed661a66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 11:18:46 +0200 Subject: [PATCH 06/12] Proto/Michelson: expose the cost of force_decode_in_context --- src/proto_alpha/lib_protocol/alpha_context.ml | 11 ++++++----- src/proto_alpha/lib_protocol/alpha_context.mli | 7 +++++++ 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index ba7306a316da..222ce87645ab 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -315,13 +315,14 @@ module Script = struct type consume_deserialization_gas = Always | When_needed + let force_decode_cost ~consume_deserialization_gas lexpr = + match consume_deserialization_gas with + | Always -> Script_repr.stable_force_decode_cost lexpr + | When_needed -> Script_repr.force_decode_cost lexpr + let force_decode_in_context ~consume_deserialization_gas ctxt lexpr = let open Result_syntax in - let gas_cost = - match consume_deserialization_gas with - | Always -> Script_repr.stable_force_decode_cost lexpr - | When_needed -> Script_repr.force_decode_cost lexpr - in + let gas_cost = force_decode_cost ~consume_deserialization_gas lexpr in let* ctxt = Raw_context.consume_gas ctxt gas_cost in let+ v = Script_repr.force_decode lexpr in (v, ctxt) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 7efffa4b1b6d..a3375201a6b5 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -732,6 +732,13 @@ module Script : sig been deserialized before. *) type consume_deserialization_gas = Always | When_needed + (** Deserialization gas cost for decoding an expression (see + {!consume_deserialization_gas}). *) + val force_decode_cost : + consume_deserialization_gas:consume_deserialization_gas -> + lazy_expr -> + Gas.cost + (** Decode an expression in the context after consuming the deserialization gas cost (see {!consume_deserialization_gas}). *) val force_decode_in_context : -- GitLab From c65354faaa6e9a3372bf2b69cf939b7ac9b0d33a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 11:22:09 +0200 Subject: [PATCH 07/12] Proto/Michelson: expose unaccounted version of force_decode --- src/proto_alpha/lib_protocol/alpha_context.ml | 4 +++- src/proto_alpha/lib_protocol/alpha_context.mli | 4 ++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 222ce87645ab..5bba16c544b5 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -320,11 +320,13 @@ module Script = struct | Always -> Script_repr.stable_force_decode_cost lexpr | When_needed -> Script_repr.force_decode_cost lexpr + let force_decode_unaccounted = Script_repr.force_decode + let force_decode_in_context ~consume_deserialization_gas ctxt lexpr = let open Result_syntax in let gas_cost = force_decode_cost ~consume_deserialization_gas lexpr in let* ctxt = Raw_context.consume_gas ctxt gas_cost in - let+ v = Script_repr.force_decode lexpr in + let+ v = force_decode_unaccounted lexpr in (v, ctxt) let force_bytes_in_context ctxt lexpr = diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index a3375201a6b5..32c4a8542f7b 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -739,6 +739,10 @@ module Script : sig lazy_expr -> Gas.cost + (** Decode an expression without consuming the deserialization gas + cost. *) + val force_decode_unaccounted : lazy_expr -> expr tzresult + (** Decode an expression in the context after consuming the deserialization gas cost (see {!consume_deserialization_gas}). *) val force_decode_in_context : -- GitLab From f928bb6082eb2565a378a9d9608e7f89de9989ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 11:35:05 +0200 Subject: [PATCH 08/12] code_size in gas monad --- .../lib_protocol/script_ir_translator.ml | 71 +++++++++---------- .../lib_protocol/script_ir_translator.mli | 8 +-- 2 files changed, 35 insertions(+), 44 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 67d9f49cd363..1217e84ba4ad 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5115,8 +5115,8 @@ let view_size view = node_size view.view_code ++ node_size view.input_ty ++ node_size view.output_ty -let code_size ctxt code views = - let open Result_syntax in +let code_size code views = + let open Gas_monad.Syntax in let open Script_typed_ir_size in let views_size = Script_map.fold (fun _ v s -> view_size v ++ s) views zero in (* The size of the storage_type and the arg_type is counted by @@ -5127,8 +5127,8 @@ let code_size ctxt code views = [node_size] (for efficiency). This is safe, as we already pay gas proportional to [views_size] and [ir_size] during their typechecking. *) - let+ ctxt = Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes) in - (code_size, ctxt) + let+$ () = Script_typed_ir_size_costs.nodes_cost ~nodes in + code_size let parse_code : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> @@ -5153,50 +5153,43 @@ let parse_code : 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 = + let* (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> Ill_formed_type (Some "parameter", code, arg_type_loc)) @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type in - let+ storage_type = + let* (Ex_ty storage_type) = Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> Ill_formed_type (Some "storage", code, storage_type_loc)) @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type in - (arg_type, storage_type, code_field, views, storage_type_loc) - in - let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type, - code_field, - views, - storage_type_loc ) = - res - in - let*? (Ty_ex_c arg_type_full) = - pair_t storage_type_loc arg_type storage_type - in - let*? (Ty_ex_c ret_type_full) = - pair_t storage_type_loc list_operation_t storage_type - in - let*? kdescr, ctxt = - Gas_monad.run ctxt - @@ parse_kdescr - ~unparse_code_rec - ~parse_packable_data:{parse_packable_data} - Tc_context.(toplevel ~storage_type ~param_type:arg_type ~entrypoints) - ~elab_conf - ~stack_depth:0 - arg_type_full - ret_type_full - code_field + let*? (Ty_ex_c arg_type_full) = + pair_t storage_type_loc arg_type storage_type + in + let*? (Ty_ex_c ret_type_full) = + pair_t storage_type_loc list_operation_t storage_type + in + let* kdescr = + Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> + Ill_typed_contract (code, [])) + @@ parse_kdescr + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data} + Tc_context.( + toplevel ~storage_type ~param_type:arg_type ~entrypoints) + ~elab_conf + ~stack_depth:0 + arg_type_full + ret_type_full + code_field + in + let code = Lam (kdescr, code_field) in + let+ code_size = code_size code views in + Ex_code + (Code {code; arg_type; storage_type; views; entrypoints; code_size}) in - let*? kdescr = record_trace (Ill_typed_contract (code, [])) kdescr in - let code = Lam (kdescr, code_field) in - let*? code_size, ctxt = code_size ctxt code views in - return - ( Ex_code - (Code {code; arg_type; storage_type; views; entrypoints; code_size}), - ctxt ) + let*? res in + return (res, ctxt) let parse_storage : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 7228270839b0..60a6733b8cb7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -474,14 +474,12 @@ val get_single_sapling_state : 'a -> (Sapling.Id.t option * context) tzresult -(** [code_size ctxt code views] returns an overapproximation of the size of - the in-memory representation of [code] and [views] in bytes in the - context [ctxt]. *) +(** [code_size code views] returns an overapproximation of the size of + the in-memory representation of [code] and [views] in bytes. *) val code_size : - context -> ('a, 'b) Script_typed_ir.lambda -> Script_typed_ir.view_map -> - (Cache_memory_helpers.sint * context) tzresult + (Cache_memory_helpers.sint, error trace) Gas_monad.t (** [script_size script] returns an overapproximation of the size of the in-memory representation of [script] in bytes as well as the cost -- GitLab From 9c8683fc8a7e74b0d93c2ae6f125c02ec0a7aef6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 11:37:29 +0200 Subject: [PATCH 09/12] parse_storage in gas monad --- .../lib_protocol/script_ir_translator.ml | 97 ++++++++++--------- .../lib_protocol/script_ir_translator.mli | 3 +- .../integration/michelson/test_sapling.ml | 17 ++-- 3 files changed, 58 insertions(+), 59 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 1217e84ba4ad..aec44c03e51e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5130,6 +5130,11 @@ let code_size code views = let+$ () = Script_typed_ir_size_costs.nodes_cost ~nodes in code_size +let force_decode ~consume_deserialization_gas lexpr = + let open Gas_monad.Syntax in + let*$ () = Script.force_decode_cost ~consume_deserialization_gas lexpr in + Gas_monad.of_result @@ Script.force_decode_unaccounted lexpr + let parse_code : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> elab_conf:elab_conf -> @@ -5139,11 +5144,10 @@ let parse_code : let open Lwt_result_syntax in fun ~unparse_code_rec ~elab_conf ctxt ~code -> let*? code, ctxt = - Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - code + Gas_monad.run ctxt + @@ force_decode ~consume_deserialization_gas:When_needed code in + let*? code in let legacy = elab_conf.legacy in let* ctxt, code = Global_constants_storage.expand ctxt code in let*? res, ctxt = @@ -5194,31 +5198,27 @@ let parse_code : let parse_storage : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> elab_conf:elab_conf -> - context -> allow_forged:bool -> ('storage, _) ty -> storage:lazy_expr -> - ('storage * context) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ~unparse_code_rec ~elab_conf ctxt ~allow_forged storage_type ~storage -> - let*? storage, ctxt = - Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - storage + ('storage, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun ~unparse_code_rec ~elab_conf ~allow_forged storage_type ~storage -> + let* storage = + force_decode ~consume_deserialization_gas:When_needed storage in - trace_eval + Gas_monad.record_trace_eval + ~error_details:(Informative ()) (fun () -> let storage_type = serialize_ty_for_error storage_type in Ill_typed_data (None, storage, storage_type)) - (parse_data + (parse_packable_data ~unparse_code_rec ~elab_conf ~stack_depth:0 ~allow_forged storage_type - (root storage) - ctxt) + (root storage)) let parse_script : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> @@ -5235,27 +5235,29 @@ let parse_script : ctxt ) = parse_code ~unparse_code_rec ~elab_conf ctxt ~code in - let+ storage, ctxt = - parse_storage - ~unparse_code_rec - ~elab_conf - ctxt - ~allow_forged:allow_forged_in_storage - storage_type - ~storage + let*? storage, ctxt = + Gas_monad.run ctxt + @@ parse_storage + ~unparse_code_rec + ~elab_conf + ~allow_forged:allow_forged_in_storage + storage_type + ~storage in - ( Ex_script - (Script - { - code_size; - code; - arg_type; - storage; - storage_type; - views; - entrypoints; - }), - ctxt ) + let*? storage in + return + ( Ex_script + (Script + { + code_size; + code; + arg_type; + storage; + storage_type; + views; + entrypoints; + }), + ctxt ) type typechecked_code_internal = | Typechecked_code_internal : { @@ -5440,19 +5442,18 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage typecheck_code ~unparse_code_rec ~legacy ~show_types:false ctxt code in let elab_conf = Script_ir_translator_config.make ~legacy ctxt in - let* storage, ctxt = - parse_storage - ~unparse_code_rec - ~elab_conf - ctxt - ~allow_forged:allow_forged_in_storage - storage_type - ~storage - in let*? code, storage = Gas_monad.run_unaccounted @@ let open Gas_monad.Syntax in + let* storage = + parse_storage + ~unparse_code_rec + ~elab_conf + ~allow_forged:allow_forged_in_storage + storage_type + ~storage + in let* code = unparse_code ~stack_depth:0 ~elab_conf mode code_field in let+ storage = unparse_data ~stack_depth:0 ~elab_conf mode storage_type storage @@ -6011,8 +6012,8 @@ let parse_views ~elab_conf ctxt ty views = let parse_code ~elab_conf ctxt ~code = parse_code ~unparse_code_rec ~elab_conf ctxt ~code -let parse_storage ~elab_conf ctxt ~allow_forged ty ~storage = - parse_storage ~unparse_code_rec ~elab_conf ctxt ~allow_forged ty ~storage +let parse_storage ~elab_conf ~allow_forged ty ~storage = + parse_storage ~unparse_code_rec ~elab_conf ~allow_forged ty ~storage let parse_script ~elab_conf ctxt ~allow_forged_in_storage script = parse_script ~unparse_code_rec ~elab_conf ctxt ~allow_forged_in_storage script diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 60a6733b8cb7..7ee238a1e48c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -345,11 +345,10 @@ val parse_code : val parse_storage : elab_conf:Script_ir_translator_config.elab_config -> - context -> allow_forged:bool -> ('storage, _) Script_typed_ir.ty -> storage:Script.lazy_expr -> - ('storage * context) tzresult Lwt.t + ('storage, error trace) Gas_monad.t (** Combines [parse_code] and [parse_storage] *) val parse_script : 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 bd21ffba4dae..97edb009b80e 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 @@ -1182,7 +1182,7 @@ module Interpreter_tests = struct let* b = next_block b operation in let* incr = Incremental.begin_construction b in let ctx = Incremental.alpha_ctxt incr in - let ctx_without_gas = Alpha_context.Gas.set_unlimited ctx in + let elab_conf = Script_ir_translator_config.make ~legacy:true ctx in let* storage = Alpha_services.Contract.storage Block.rpc_ctxt b dst in let storage_lazy_expr = Alpha_context.Script.lazy_expr storage in let*?@ (Ty_ex_c tytype) = @@ -1191,14 +1191,13 @@ module Interpreter_tests = struct let state_ty = sapling_state_t ~memo_size in pair_t (-1) state_ty state_ty in - let*@ (state_1, state_2), _ctx = - Script_ir_translator.parse_storage - ctx_without_gas - ~elab_conf: - (Script_ir_translator_config.make ~legacy:true ctx_without_gas) - ~allow_forged:true - tytype - ~storage:storage_lazy_expr + let*?@ state_1, state_2 = + Gas_monad.run_unaccounted + @@ Script_ir_translator.parse_storage + ~elab_conf + ~allow_forged:true + tytype + ~storage:storage_lazy_expr in (*Only works when diff is empty*) let local_state_from_disk disk_state ctx = -- GitLab From 9274e0df4f8af6996849b5bb88e73eaf025dfb4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 13:29:36 +0200 Subject: [PATCH 10/12] pack_data and hash_data in gas monad --- .../interpreter_benchmarks.ml | 23 +++++++++--------- src/proto_alpha/lib_plugin/RPC.ml | 24 +++++++++---------- .../lib_protocol/script_interpreter.ml | 13 +++++++--- .../lib_protocol/script_ir_translator.ml | 24 ++++++++----------- .../lib_protocol/script_ir_translator.mli | 8 +++---- .../test/helpers/lqt_fa12_repr.ml | 10 ++++++-- .../integration/michelson/test_sapling.ml | 11 +++++++-- .../test/pbt/test_script_comparison.ml | 3 ++- 8 files changed, 66 insertions(+), 50 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml index 42a423883b39..d0d8a15c6773 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_benchmarks.ml @@ -3139,22 +3139,21 @@ module Registration_section = struct {stack = ((), eos); stack_type = unit @$ bot; kinstr}) () + let ctxt, _ = + raise_if_error + (Lwt_main.run + (Execution_context.make ~rng_state:(Random.get_state ()) ())) + + let elab_conf = Script_ir_translator_config.make ~legacy:false ctxt + let () = - let open Lwt_result_syntax in time_alloc_benchmark ~name:Interpreter_workload.N_IUnpack - ~kinstr_and_stack_sampler:(fun _cfg rng_state -> + ~kinstr_and_stack_sampler:(fun _cfg _rng_state -> let b = - raise_if_error - (Lwt_main.run - (let* ctxt, _ = Execution_context.make ~rng_state () in - let* bytes, _ = - let*! result = - Script_ir_translator.pack_data ctxt unit () - in - Lwt.return (Environment.wrap_tzresult result) - in - return bytes)) + raise_if_error @@ Environment.wrap_tzresult + @@ Gas_monad.run_unaccounted + @@ Script_ir_translator.pack_data ~elab_conf unit () in let kinstr = IUnpack (dummy_loc, unit, halt) in fun () -> diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 75a841e7de24..de41eba47fb6 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1684,21 +1684,21 @@ module Scripts = struct | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in + let elab_conf = elab_conf ~legacy:true ctxt in let*? res, ctxt = Gas_monad.run ctxt - @@ parse_packable_ty ~legacy:true (Micheline.root typ) - in - let*? (Ex_ty typ) = res in - let* data, ctxt = - parse_data - ctxt - ~elab_conf:(elab_conf ~legacy:true ctxt) - ~allow_forged:true - typ - (Micheline.root expr) + @@ + let open Gas_monad.Syntax in + let* (Ex_ty typ) = + parse_packable_ty ~legacy:true (Micheline.root typ) + in + let* data = + parse_packable_data ~elab_conf typ (Micheline.root expr) + in + pack_data ~elab_conf typ data in - let+ bytes, ctxt = Script_ir_translator.pack_data ctxt typ data in - (bytes, Gas.level ctxt)) ; + let*? res in + return (res, Gas.level ctxt)) ; Registration.register0 ~chunked:true S.normalize_data diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index b2d8a72e9d39..46e4d745f3e7 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1221,10 +1221,17 @@ module Raw = struct (* packing *) | IPack (_, ty, k) -> let value = accu in - let* bytes, ctxt, gas = - use_gas_counter_in_context ctxt gas @@ fun ctxt -> - Script_ir_translator.pack_data ctxt ty value + let ctxt = update_context gas ctxt in + let*? bytes, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.pack_data + ~elab_conf: + Script_ir_translator_config.(make ~legacy:true ctxt) + ty + value in + let*? bytes in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack | IUnpack (_, ty, k) -> let bytes = accu in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index aec44c03e51e..889af32153db 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5533,22 +5533,18 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ( {code = lazy_expr (strip_locations code); storage = lazy_expr storage}, ctxt ) -let pack_data_with_mode ctxt ty data ~mode = - let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in - let*? unparsed, ctxt = - Gas_monad.run ctxt @@ unparse_data ~stack_depth:0 ~elab_conf mode ty data - in - let*? unparsed in - return (pack_node unparsed, ctxt) +let pack_data_with_mode ~elab_conf ty data ~mode = + let open Gas_monad.Syntax in + let+ unparsed = unparse_data ~stack_depth:0 ~elab_conf mode ty data in + pack_node unparsed -let hash_data ctxt ty data = - let open Lwt_result_syntax in - let* bytes, ctxt = pack_data_with_mode ctxt ty data ~mode:Optimized_legacy in - Lwt.return @@ Gas_monad.run_pure ctxt @@ hash_bytes bytes +let hash_data ~elab_conf ty data = + let open Gas_monad.Syntax in + let* bytes = pack_data_with_mode ~elab_conf ty data ~mode:Optimized_legacy in + hash_bytes bytes -let pack_data ctxt ty data = - pack_data_with_mode ctxt ty data ~mode:Optimized_legacy +let pack_data ~elab_conf ty data = + pack_data_with_mode ~elab_conf ty data ~mode:Optimized_legacy (* ---------------- Lazy storage---------------------------------------------*) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 7ee238a1e48c..6d8e7bae4a28 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -410,10 +410,10 @@ val list_entrypoints_uncarbonated : * (ex_ty * Script.node) Entrypoint.Map.t val pack_data : - context -> + elab_conf:Script_ir_translator_config.elab_config -> ('a, _) Script_typed_ir.ty -> 'a -> - (bytes * context) tzresult Lwt.t + (bytes, error trace) Gas_monad.t val hash_comparable_data : 'a Script_typed_ir.comparable_ty -> @@ -421,10 +421,10 @@ val hash_comparable_data : (Script_expr_hash.t, error trace) Gas_monad.t val hash_data : - context -> + elab_conf:Script_ir_translator_config.elab_config -> ('a, _) Script_typed_ir.ty -> 'a -> - (Script_expr_hash.t * context) tzresult Lwt.t + (Script_expr_hash.t, error trace) Gas_monad.t type lazy_storage_ids diff --git a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml index 47f8bde4e4b8..263dcba2cd6a 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/lqt_fa12_repr.ml @@ -226,9 +226,15 @@ module Storage = struct let* storage = get ctxt ~contract in let tokens = storage.tokens in let* ctxt = get_alpha_context ctxt in - let*@ address_hash, ctxt = - Script_ir_translator.hash_data ctxt Script_typed_ir.address_t owner + let elab_conf = Script_ir_translator_config.(make ~legacy:true ctxt) in + let*?@ address_hash, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.hash_data + ~elab_conf + Script_typed_ir.address_t + owner in + let*?@ address_hash in let*@ _, result = Big_map.get_opt ctxt tokens address_hash in match result with | Some canonical -> ( 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 97edb009b80e..bcb5ee577ad2 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 @@ -707,8 +707,15 @@ module Interpreter_tests = struct let pkh = Context.Contract.pkh src1 in let* incr = Incremental.begin_construction b3 in let alpha_ctxt = Incremental.alpha_ctxt incr in - let*@ bound_data, _alpha_ctxt = - Script_ir_translator.pack_data alpha_ctxt Script_typed_ir.key_hash_t pkh + let elab_conf = + Script_ir_translator_config.(make ~legacy:true alpha_ctxt) + in + let*?@ bound_data = + Gas_monad.run_unaccounted + @@ Script_ir_translator.pack_data + ~elab_conf + Script_typed_ir.key_hash_t + pkh in let hex_transac = to_hex diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index d6dba734d05f..7e4b4c1ef895 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -211,7 +211,8 @@ let unparse_comparable_data ty x = Script_ir_translator.(unparse_data ~elab_conf Readable ty x)) let pack_comparable_data ty x = - fst (assert_return Script_ir_translator.(pack_data ctxt ty x)) + assert_ok + (Gas_monad.run_unaccounted Script_ir_translator.(pack_data ~elab_conf ty x)) let unpack_comparable_data ty bytes = fst (assert_return (Script_interpreter_defs.unpack ctxt ~ty ~bytes)) -- GitLab From c1d8a3f5c98990e5a0f6134b1932abf73d8f8fc6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 13:37:51 +0200 Subject: [PATCH 11/12] Expose run_on_gas_counter --- src/proto_alpha/lib_protocol/gas_monad.mli | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index db86e40499f1..97a85a7061a1 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -79,6 +79,13 @@ val run_pure : gas consumptions are ignored. *) val run_unaccounted : ('a, error trace) t -> 'a tzresult +(** [run_on_gas_counter m] is a variant of [run] which runs on a mere + gas counter instead of a full context. *) +val run_on_gas_counter : + Local_gas_counter.local_gas_counter -> + ('a, 'trace) t -> + (('a, 'trace) result * Local_gas_counter.local_gas_counter) tzresult + (** [record_trace_level ~error_details f m] returns a new gas-monad value that when run, records trace levels using [f]. This function has no effect in the case of a gas-exhaustion error or if [error_details] is [Fast]. *) -- GitLab From cedb9843c29399dc39ae6e0d3f06ff1df4df556c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 26 Sep 2023 13:56:35 +0200 Subject: [PATCH 12/12] Simplify Pack case in interpreter --- .../lib_protocol/script_interpreter.ml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 46e4d745f3e7..8f3b972f661c 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1221,17 +1221,16 @@ module Raw = struct (* packing *) | IPack (_, ty, k) -> let value = accu in - let ctxt = update_context gas ctxt in - let*? bytes, ctxt = - Gas_monad.run ctxt - @@ Script_ir_translator.pack_data - ~elab_conf: - Script_ir_translator_config.(make ~legacy:true ctxt) - ty - value + let elab_conf = + Script_ir_translator_config.make + ~legacy:true + (update_context gas ctxt) + in + let*? bytes, gas = + Gas_monad.run_on_gas_counter gas + @@ Script_ir_translator.pack_data ~elab_conf ty value in let*? bytes in - let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack | IUnpack (_, ty, k) -> let bytes = accu in -- GitLab