From 680b220623f4a6277ae83160e08e98f70dddcc14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Sun, 17 Sep 2023 23:37:28 +0200 Subject: [PATCH 01/17] Raise parse_contract* --- .../lib_protocol/script_ir_translator.ml | 426 +++++++++--------- 1 file changed, 213 insertions(+), 213 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index fbfcc745feae..3d99cafdc24f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2031,6 +2031,219 @@ let normalized_lam_rec ~unparse_code_rec ~stack_depth ctxt kdescr code_field = in (LamRec (kdescr, code_field), ctxt) +(* [parse_contract] is used both to: + - parse contract data by [parse_data] ([parse_contract_data]) + - to execute the [CONTRACT] instruction ([parse_contract_for_script]). + + The return type resembles the [Gas_monad]: + - the outer [tzresult] is for gas exhaustion and internal errors + - the inner [result] is for other legitimate cases of failure. + + The inner [result] is turned into an [option] by [parse_contract_for_script]. + Both [tzresult] are merged by [parse_contract_data]. +*) +let parse_contract : + type arg argc err. + stack_depth:int -> + context -> + error_details:(location, err) error_details -> + Script.location -> + (arg, argc) ty -> + Destination.t -> + entrypoint:Entrypoint.t -> + (context * (arg typed_contract, err) result) tzresult Lwt.t = + let open Lwt_result_syntax in + fun ~stack_depth ctxt ~error_details loc arg destination ~entrypoint -> + let error ctxt f_err : context * (_, err) result = + ( ctxt, + Error + (match error_details with + | Fast -> (Inconsistent_types_fast : err) + | Informative loc -> trace_of_error @@ f_err loc) ) + in + let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in + match destination with + | Contract contract -> ( + match contract with + | Implicit destination -> + if Entrypoint.is_default entrypoint then + (* An implicit account on the "default" entrypoint always exists and has type unit + or (ticket cty). *) + let typecheck = + let open Gas_monad.Syntax in + let*$ () = Typecheck_costs.ty_eq_prim in + match arg with + | Unit_t -> + return (Typed_implicit destination : arg typed_contract) + | Ticket_t _ as ticket_ty -> + return (Typed_implicit_with_ticket {ticket_ty; destination}) + | _ -> + Gas_monad.of_result + @@ Error + (match error_details with + | Fast -> (Inconsistent_types_fast : err) + | Informative loc -> + trace_of_error + @@ Unexpected_implicit_account_parameters_type + (loc, serialize_ty_for_error arg)) + in + let*? v, ctxt = Gas_monad.run ctxt typecheck in + return (ctxt, v) + else + (* An implicit account on any other entrypoint is not a valid contract. *) + return @@ error ctxt (fun _loc -> No_such_entrypoint entrypoint) + | Originated contract_hash -> + trace + (Invalid_contract (loc, contract)) + (let* ctxt, code = Contract.get_script_code ctxt contract_hash in + match code with + | None -> + return + (error ctxt (fun loc -> Invalid_contract (loc, contract))) + | Some code -> + let*? code, ctxt = + Script.force_decode_in_context + ~consume_deserialization_gas:When_needed + ctxt + code + in + let*? targ, ctxt = + Gas_monad.run ctxt + @@ + 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}) = + targ + in + let*? entrypoint_arg, ctxt = + Gas_monad.run ctxt + @@ find_entrypoint_for_type + ~error_details + ~full:targ + ~expected:arg + entrypoints + entrypoint + in + return + ( ctxt, + let open Result_syntax in + let* entrypoint, arg_ty = entrypoint_arg in + Ok (Typed_originated {arg_ty; contract_hash; entrypoint}) + ))) + | Zk_rollup zk_rollup -> + let+ ctxt = Zk_rollup.assert_exist ctxt zk_rollup in + if Entrypoint.(is_deposit entrypoint) then + match arg with + | Pair_t (Ticket_t (_, _), Bytes_t, _, _) -> + ( ctxt, + Ok + (Typed_zk_rollup {arg_ty = arg; zk_rollup} + : arg typed_contract) ) + | _ -> + error ctxt (fun loc -> + Zk_rollup_bad_deposit_parameter + (loc, serialize_ty_for_error arg)) + else error ctxt (fun _loc -> No_such_entrypoint entrypoint) + | Sc_rollup sc_rollup -> ( + let* parameters_type, ctxt = Sc_rollup.parameters_type ctxt sc_rollup in + match parameters_type with + | None -> + return + (error ctxt (fun _loc -> + Sc_rollup.Errors.Sc_rollup_does_not_exist sc_rollup)) + | Some parameters_type -> + let*? parameters_type, ctxt = + Script.force_decode_in_context + ~consume_deserialization_gas:When_needed + ctxt + parameters_type + in + let*? full, ctxt = + Gas_monad.run ctxt + @@ parse_parameter_ty_and_entrypoints + ~stack_depth:(stack_depth + 1) + ~legacy:true + (root parameters_type) + in + let*? (Ex_parameter_ty_and_entrypoints + {arg_type = full; entrypoints}) = + full + in + let*? entrypoint_arg, ctxt = + Gas_monad.run ctxt + @@ find_entrypoint_for_type + ~error_details + ~full + ~expected:arg + entrypoints + entrypoint + in + return + ( ctxt, + let open Result_syntax in + let* entrypoint, arg_ty = entrypoint_arg in + Ok (Typed_sc_rollup {arg_ty; sc_rollup; entrypoint}) )) + +let parse_contract_data : + type arg argc. + stack_depth:int -> + context -> + Script.location -> + (arg, argc) ty -> + Destination.t -> + entrypoint:Entrypoint.t -> + (context * arg typed_contract) tzresult Lwt.t = + let open Lwt_result_syntax in + fun ~stack_depth ctxt loc arg destination ~entrypoint -> + let error_details = Informative loc in + let* ctxt, res = + parse_contract + ~stack_depth:(stack_depth + 1) + ctxt + ~error_details + loc + arg + destination + ~entrypoint + in + let*? res in + return (ctxt, res) + +(* Same as [parse_contract], but does not fail when the contact is missing or + if the expected type doesn't match the actual one. In that case None is + returned and some overapproximation of the typechecking gas is consumed. + This can still fail on gas exhaustion. *) +let parse_contract_for_script : + type arg argc. + context -> + Script.location -> + (arg, argc) ty -> + Destination.t -> + entrypoint:Entrypoint.t -> + (context * arg typed_contract option) tzresult Lwt.t = + let open Lwt_result_syntax in + fun ctxt loc arg destination ~entrypoint -> + let+ ctxt, res = + parse_contract + ~stack_depth:0 + ctxt + ~error_details:Fast + loc + arg + destination + ~entrypoint + in + ( ctxt, + match res with + | Ok res -> Some res + | Error Inconsistent_types_fast -> None ) + (* -- parse data of any type -- *) (* @@ -4918,219 +5131,6 @@ and parse_instr : I_XOR; ] -and parse_contract_data : - type arg argc. - stack_depth:int -> - context -> - Script.location -> - (arg, argc) ty -> - Destination.t -> - entrypoint:Entrypoint.t -> - (context * arg typed_contract) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ~stack_depth ctxt loc arg destination ~entrypoint -> - let error_details = Informative loc in - let* ctxt, res = - parse_contract - ~stack_depth:(stack_depth + 1) - ctxt - ~error_details - loc - arg - destination - ~entrypoint - in - let*? res in - return (ctxt, res) - -(* [parse_contract] is used both to: - - parse contract data by [parse_data] ([parse_contract_data]) - - to execute the [CONTRACT] instruction ([parse_contract_for_script]). - - The return type resembles the [Gas_monad]: - - the outer [tzresult] is for gas exhaustion and internal errors - - the inner [result] is for other legitimate cases of failure. - - The inner [result] is turned into an [option] by [parse_contract_for_script]. - Both [tzresult] are merged by [parse_contract_data]. -*) -and parse_contract : - type arg argc err. - stack_depth:int -> - context -> - error_details:(location, err) error_details -> - Script.location -> - (arg, argc) ty -> - Destination.t -> - entrypoint:Entrypoint.t -> - (context * (arg typed_contract, err) result) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ~stack_depth ctxt ~error_details loc arg destination ~entrypoint -> - let error ctxt f_err : context * (_, err) result = - ( ctxt, - Error - (match error_details with - | Fast -> (Inconsistent_types_fast : err) - | Informative loc -> trace_of_error @@ f_err loc) ) - in - let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in - match destination with - | Contract contract -> ( - match contract with - | Implicit destination -> - if Entrypoint.is_default entrypoint then - (* An implicit account on the "default" entrypoint always exists and has type unit - or (ticket cty). *) - let typecheck = - let open Gas_monad.Syntax in - let*$ () = Typecheck_costs.ty_eq_prim in - match arg with - | Unit_t -> - return (Typed_implicit destination : arg typed_contract) - | Ticket_t _ as ticket_ty -> - return (Typed_implicit_with_ticket {ticket_ty; destination}) - | _ -> - Gas_monad.of_result - @@ Error - (match error_details with - | Fast -> (Inconsistent_types_fast : err) - | Informative loc -> - trace_of_error - @@ Unexpected_implicit_account_parameters_type - (loc, serialize_ty_for_error arg)) - in - let*? v, ctxt = Gas_monad.run ctxt typecheck in - return (ctxt, v) - else - (* An implicit account on any other entrypoint is not a valid contract. *) - return @@ error ctxt (fun _loc -> No_such_entrypoint entrypoint) - | Originated contract_hash -> - trace - (Invalid_contract (loc, contract)) - (let* ctxt, code = Contract.get_script_code ctxt contract_hash in - match code with - | None -> - return - (error ctxt (fun loc -> Invalid_contract (loc, contract))) - | Some code -> - let*? code, ctxt = - Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - code - in - let*? targ, ctxt = - Gas_monad.run ctxt - @@ - 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}) = - targ - in - let*? entrypoint_arg, ctxt = - Gas_monad.run ctxt - @@ find_entrypoint_for_type - ~error_details - ~full:targ - ~expected:arg - entrypoints - entrypoint - in - return - ( ctxt, - let open Result_syntax in - let* entrypoint, arg_ty = entrypoint_arg in - Ok (Typed_originated {arg_ty; contract_hash; entrypoint}) - ))) - | Zk_rollup zk_rollup -> - let+ ctxt = Zk_rollup.assert_exist ctxt zk_rollup in - if Entrypoint.(is_deposit entrypoint) then - match arg with - | Pair_t (Ticket_t (_, _), Bytes_t, _, _) -> - ( ctxt, - Ok - (Typed_zk_rollup {arg_ty = arg; zk_rollup} - : arg typed_contract) ) - | _ -> - error ctxt (fun loc -> - Zk_rollup_bad_deposit_parameter - (loc, serialize_ty_for_error arg)) - else error ctxt (fun _loc -> No_such_entrypoint entrypoint) - | Sc_rollup sc_rollup -> ( - let* parameters_type, ctxt = Sc_rollup.parameters_type ctxt sc_rollup in - match parameters_type with - | None -> - return - (error ctxt (fun _loc -> - Sc_rollup.Errors.Sc_rollup_does_not_exist sc_rollup)) - | Some parameters_type -> - let*? parameters_type, ctxt = - Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - parameters_type - in - let*? full, ctxt = - Gas_monad.run ctxt - @@ parse_parameter_ty_and_entrypoints - ~stack_depth:(stack_depth + 1) - ~legacy:true - (root parameters_type) - in - let*? (Ex_parameter_ty_and_entrypoints - {arg_type = full; entrypoints}) = - full - in - let*? entrypoint_arg, ctxt = - Gas_monad.run ctxt - @@ find_entrypoint_for_type - ~error_details - ~full - ~expected:arg - entrypoints - entrypoint - in - return - ( ctxt, - let open Result_syntax in - let* entrypoint, arg_ty = entrypoint_arg in - Ok (Typed_sc_rollup {arg_ty; sc_rollup; entrypoint}) )) - -(* Same as [parse_contract], but does not fail when the contact is missing or - if the expected type doesn't match the actual one. In that case None is - returned and some overapproximation of the typechecking gas is consumed. - This can still fail on gas exhaustion. *) -let parse_contract_for_script : - type arg argc. - context -> - Script.location -> - (arg, argc) ty -> - Destination.t -> - entrypoint:Entrypoint.t -> - (context * arg typed_contract option) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ctxt loc arg destination ~entrypoint -> - let+ ctxt, res = - parse_contract - ~stack_depth:0 - ctxt - ~error_details:Fast - loc - arg - destination - ~entrypoint - in - ( ctxt, - match res with - | Ok res -> Some res - | Error Inconsistent_types_fast -> None ) - let view_size view = let open Script_typed_ir_size in node_size view.view_code ++ node_size view.input_ty -- GitLab From ac924797ee989a16dd7a7cfe6259f51232c8f448 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 11:26:20 +0200 Subject: [PATCH 02/17] Move parse_data down --- .../lib_protocol/script_ir_translator.ml | 938 +++++++++--------- 1 file changed, 469 insertions(+), 469 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 3d99cafdc24f..56fe442ab03f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2244,463 +2244,7 @@ let parse_contract_for_script : | Ok res -> Some res | Error Inconsistent_types_fast -> None ) -(* -- parse data of any type -- *) - -(* - Some values, such as operations, tickets, or big map ids, are used only - internally and are not allowed to be forged by users. - In [parse_data], [allow_forged] should be [false] for: - - PUSH - - UNPACK - - user-provided script parameters - - storage on origination - And [true] for: - - internal calls parameters - - storage after origination - *) - -let rec parse_data : - type a ac. - unparse_code_rec:Script_ir_unparser.unparse_code_rec -> - elab_conf:elab_conf -> - stack_depth:int -> - context -> - allow_forged:bool -> - (a, ac) ty -> - Script.node -> - (a * context) tzresult Lwt.t = - fun ~unparse_code_rec ~elab_conf ~stack_depth ctxt ~allow_forged ty script_data -> - let open Lwt_result_syntax in - let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in - let non_terminal_recursion ctxt ty script_data = - if Compare.Int.(stack_depth > 10_000) then - tzfail Typechecking_too_many_recursive_calls - else - parse_data - ~unparse_code_rec - ~elab_conf - ~stack_depth:(stack_depth + 1) - ctxt - ~allow_forged - ty - script_data - in - let parse_data_error () = - let ty = serialize_ty_for_error ty in - Invalid_constant (location script_data, strip_locations script_data, ty) - in - let fail_parse_data () = tzfail (parse_data_error ()) in - let traced_no_lwt body = record_trace_eval parse_data_error body in - let traced body = trace_eval parse_data_error body in - let traced_from_gas_monad ctxt body = - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - let* res, ctxt = Gas_monad.run ctxt body in - let+ res in - (res, ctxt) - in - let traced_fail err = - Lwt.return @@ traced_no_lwt (Result_syntax.tzfail err) - in - let parse_items ctxt expr key_type value_type items item_wrapper = - let+ _, items, ctxt = - List.fold_left_es - (fun (last_value, map, ctxt) item -> - match item with - | Prim (loc, D_Elt, [k; v], annot) -> - let*? () = - if elab_conf.legacy (* Legacy check introduced before Ithaca. *) - then Result_syntax.return_unit - else error_unexpected_annot loc annot - in - let* k, ctxt = non_terminal_recursion ctxt key_type k in - let* v, ctxt = non_terminal_recursion ctxt value_type v in - let*? ctxt = - let open Result_syntax in - match last_value with - | Some value -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - key_type - value - k) - in - let c = - Script_comparable.compare_comparable key_type value k - in - if Compare.Int.(0 <= c) then - if Compare.Int.(0 = c) then - tzfail (Duplicate_map_keys (loc, strip_locations expr)) - else - tzfail (Unordered_map_keys (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt - in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.map_update k map) - in - return - (Some k, Script_map.update k (Some (item_wrapper v)) map, ctxt) - | Prim (loc, D_Elt, l, _) -> - tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) - | Prim (loc, name, _, _) -> - tzfail @@ Invalid_primitive (loc, [D_Elt], name) - | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) - (None, Script_map.empty key_type, ctxt) - items - |> traced - in - (items, ctxt) - in - let parse_big_map_items (type t) ctxt expr (key_type : t comparable_ty) - value_type items item_wrapper = - let+ _, map, ctxt = - List.fold_left_es - (fun (last_key, {map; size}, ctxt) item -> - match item with - | Prim (loc, D_Elt, [k; v], annot) -> - let*? () = - if elab_conf.legacy (* Legacy check introduced before Ithaca. *) - then Result_syntax.return_unit - else error_unexpected_annot loc annot - in - let* k, ctxt = non_terminal_recursion ctxt key_type k in - let* key_hash, ctxt = hash_comparable_data ctxt key_type k in - let* v, ctxt = non_terminal_recursion ctxt value_type v in - let*? ctxt = - let open Result_syntax in - match last_key with - | Some last_key -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - key_type - last_key - k) - in - let c = - Script_comparable.compare_comparable key_type last_key k - in - if Compare.Int.(0 <= c) then - if Compare.Int.(0 = c) then - tzfail (Duplicate_map_keys (loc, strip_locations expr)) - else - tzfail (Unordered_map_keys (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt - in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.big_map_update - {map; size}) - in - if Big_map_overlay.mem key_hash map then - tzfail (Duplicate_map_keys (loc, strip_locations expr)) - else - return - ( Some k, - { - map = Big_map_overlay.add key_hash (k, item_wrapper v) map; - size = size + 1; - }, - ctxt ) - | Prim (loc, D_Elt, l, _) -> - tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) - | Prim (loc, name, _, _) -> - tzfail @@ Invalid_primitive (loc, [D_Elt], name) - | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) - (None, {map = Big_map_overlay.empty; size = 0}, ctxt) - items - |> traced - in - (map, ctxt) - in - let legacy = elab_conf.legacy in - match (ty, script_data) with - | Unit_t, expr -> - traced_from_gas_monad ctxt - @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) - | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr - | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr - | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr - | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr - | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr - | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr - | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr - | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr - | Key_hash_t, expr -> traced_from_gas_monad ctxt @@ parse_key_hash expr - | Signature_t, expr -> traced_from_gas_monad ctxt @@ parse_signature expr - | Operation_t, _ -> - (* operations cannot appear in parameters or storage, - the protocol should never parse the bytes of an operation *) - assert false - | Chain_id_t, expr -> traced_from_gas_monad ctxt @@ parse_chain_id expr - | Address_t, expr -> - traced_from_gas_monad ctxt - @@ parse_address - ~sc_rollup_enable:elab_conf.sc_rollup_enable - ~zk_rollup_enable:elab_conf.zk_rollup_enable - expr - | Contract_t (arg_ty, _), expr -> - traced - (let*? address, ctxt = - Gas_monad.run ctxt - @@ parse_address - ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) - ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) - expr - in - let*? address in - let loc = location expr in - let+ ctxt, typed_contract = - parse_contract_data - ~stack_depth:(stack_depth + 1) - ctxt - loc - arg_ty - address.destination - ~entrypoint:address.entrypoint - in - (typed_contract, ctxt)) - (* Pairs *) - | Pair_t (tl, tr, _, _), expr -> - let r_witness = comb_witness1 tr in - let parse_l ctxt v = non_terminal_recursion ctxt tl v in - let parse_r ctxt v = non_terminal_recursion ctxt tr v in - traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr - (* Ors *) - | Or_t (tl, tr, _, _), expr -> - let parse_l ctxt v = non_terminal_recursion ctxt tl v in - let parse_r ctxt v = non_terminal_recursion ctxt tr v in - traced @@ parse_or parse_l parse_r ctxt ~legacy expr - (* Lambdas *) - | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> - let* kdescr, ctxt = - traced - @@ parse_kdescr - ~unparse_code_rec - Tc_context.data - ~elab_conf - ~stack_depth:(stack_depth + 1) - ctxt - ta - tr - script_instr - in - (normalized_lam [@ocaml.tailcall]) - ~unparse_code_rec - ctxt - ~stack_depth - kdescr - script_instr - | ( Lambda_t (ta, tr, _ty_name), - Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) -> - traced - @@ let*? lambda_rec_ty = lambda_t loc ta tr in - parse_lam_rec - ~unparse_code_rec - Tc_context.(add_lambda data) - ~elab_conf - ~stack_depth:(stack_depth + 1) - ctxt - ta - tr - lambda_rec_ty - script_instr - | Lambda_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - (* Options *) - | Option_t (t, _, _), expr -> - let parse_v ctxt v = non_terminal_recursion ctxt t v in - traced @@ parse_option parse_v ctxt ~legacy expr - (* Lists *) - | List_t (t, _ty_name), Seq (_loc, items) -> - traced - @@ List.fold_left_es - (fun (rest, ctxt) v -> - let+ v, ctxt = non_terminal_recursion ctxt t v in - (Script_list.cons v rest, ctxt)) - (Script_list.empty, ctxt) - (List.rev items) - | List_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - (* Tickets *) - | Ticket_t (t, _ty_name), expr -> - if allow_forged then - let*? ty = opened_ticket_type (location expr) t in - let* ({destination; entrypoint = _}, (contents, amount)), ctxt = - non_terminal_recursion ctxt ty expr - in - match Ticket_amount.of_n amount with - | Some amount -> ( - match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) - | Sc_rollup _ | Zk_rollup _ -> - tzfail (Unexpected_ticket_owner destination)) - | None -> traced_fail Forbidden_zero_ticket_quantity - else traced_fail (Unexpected_forged_value (location expr)) - (* Sets *) - | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> - let+ _, set, ctxt = - traced - @@ List.fold_left_es - (fun (last_value, set, ctxt) v -> - let* v, ctxt = non_terminal_recursion ctxt t v in - let*? ctxt = - let open Result_syntax in - match last_value with - | Some value -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - t - value - v) - in - let c = Script_comparable.compare_comparable t value v in - if Compare.Int.(0 <= c) then - if Compare.Int.(0 = c) then - tzfail - (Duplicate_set_values (loc, strip_locations expr)) - else - tzfail - (Unordered_set_values (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt - in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.set_update v set) - in - return (Some v, Script_set.update v true set, ctxt)) - (None, Script_set.empty t, ctxt) - vs - in - (set, ctxt) - | Set_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - (* Maps *) - | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - parse_items ctxt expr tk tv vs (fun x -> x) - | Map_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - | Big_map_t (tk, tv, _ty_name), expr -> - let* id_opt, diff, ctxt = - match expr with - | Int (loc, id) -> - return - (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) - | Seq (_, vs) -> - let+ diff, ctxt = - parse_big_map_items ctxt expr tk tv vs (fun x -> Some x) - in - (None, diff, ctxt) - | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) -> - let*? () = error_unexpected_annot loc annot in - let*? tv_opt = option_t loc tv in - let+ diff, ctxt = - parse_big_map_items ctxt expr tk tv_opt vs (fun x -> x) - in - (Some (id, loc_id), diff, ctxt) - | Prim (_, D_Pair, [Int _; expr], _) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - | Prim (_, D_Pair, [expr; _], _) -> - traced_fail (Invalid_kind (location expr, [Int_kind], kind expr)) - | Prim (loc, D_Pair, l, _) -> - traced_fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) - | _ -> - traced_fail - (unexpected expr [Seq_kind; Int_kind] Constant_namespace [D_Pair]) - in - let+ id, ctxt = - match id_opt with - | None -> return (None, ctxt) - | Some (id, loc) -> - if allow_forged then - let id = Big_map.Id.parse_z id in - let* ctxt, tys_opt = Big_map.exists ctxt id in - match tys_opt with - | None -> traced_fail (Invalid_big_map (loc, id)) - | Some (btk, btv) -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* (Ex_comparable_ty btk) = - parse_comparable_ty - ~stack_depth:(stack_depth + 1) - (Micheline.root btk) - in - let* (Ex_ty btv) = - parse_big_map_value_ty - ~stack_depth:(stack_depth + 1) - ~legacy - (Micheline.root btv) - in - let+ Eq = - let error_details = Informative loc in - let* Eq = ty_eq ~error_details tk btk in - ty_eq ~error_details tv btv - in - Some id - in - let*? res in - return (res, ctxt) - else traced_fail (Unexpected_forged_value loc) - in - (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) - | Never_t, expr -> traced_from_gas_monad ctxt @@ parse_never expr - (* Bls12_381 types *) - | Bls12_381_g1_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_g1 expr - | Bls12_381_g2_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_g2 expr - | Bls12_381_fr_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_fr expr - (* - /!\ When adding new lazy storage kinds, you may want to guard the parsing - of identifiers with [allow_forged]. - *) - (* Sapling *) - | Sapling_transaction_t memo_size, expr -> - traced_from_gas_monad ctxt @@ parse_sapling_transaction ~memo_size expr - | Sapling_transaction_deprecated_t memo_size, expr -> - traced_from_gas_monad ctxt - @@ parse_sapling_transaction_deprecated ~memo_size expr - | Sapling_state_t memo_size, Int (loc, id) -> - if allow_forged then - let id = Sapling.Id.parse_z id in - let* state, ctxt = Sapling.state_from_id ctxt id in - let*? () = - traced_no_lwt - @@ memo_size_eq - ~error_details:(Informative ()) - memo_size - state.Sapling.memo_size - in - return (state, ctxt) - else traced_fail (Unexpected_forged_value loc) - | Sapling_state_t memo_size, Seq (_, []) -> - return (Sapling.empty_state ~memo_size (), ctxt) - | Sapling_state_t _, expr -> - (* Do not allow to input diffs as they are untrusted and may not be the - result of a verify_update. *) - traced_fail - (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) - (* Time lock*) - | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr - | Chest_t, expr -> traced_from_gas_monad ctxt @@ parse_chest expr - -and parse_view : +let rec parse_view : type storage storagec. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> elab_conf:elab_conf -> @@ -5131,6 +4675,462 @@ and parse_instr : I_XOR; ] +(* -- parse data of any type -- *) + +(* + Some values, such as operations, tickets, or big map ids, are used only + internally and are not allowed to be forged by users. + In [parse_data], [allow_forged] should be [false] for: + - PUSH + - UNPACK + - user-provided script parameters + - storage on origination + And [true] for: + - internal calls parameters + - storage after origination + *) + +and parse_data : + type a ac. + unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + elab_conf:elab_conf -> + stack_depth:int -> + context -> + allow_forged:bool -> + (a, ac) ty -> + Script.node -> + (a * context) tzresult Lwt.t = + fun ~unparse_code_rec ~elab_conf ~stack_depth ctxt ~allow_forged ty script_data -> + let open Lwt_result_syntax in + let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in + let non_terminal_recursion ctxt ty script_data = + if Compare.Int.(stack_depth > 10_000) then + tzfail Typechecking_too_many_recursive_calls + else + parse_data + ~unparse_code_rec + ~elab_conf + ~stack_depth:(stack_depth + 1) + ctxt + ~allow_forged + ty + script_data + in + let parse_data_error () = + let ty = serialize_ty_for_error ty in + Invalid_constant (location script_data, strip_locations script_data, ty) + in + let fail_parse_data () = tzfail (parse_data_error ()) in + let traced_no_lwt body = record_trace_eval parse_data_error body in + let traced body = trace_eval parse_data_error body in + let traced_from_gas_monad ctxt body = + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in + let* res, ctxt = Gas_monad.run ctxt body in + let+ res in + (res, ctxt) + in + let traced_fail err = + Lwt.return @@ traced_no_lwt (Result_syntax.tzfail err) + in + let parse_items ctxt expr key_type value_type items item_wrapper = + let+ _, items, ctxt = + List.fold_left_es + (fun (last_value, map, ctxt) item -> + match item with + | Prim (loc, D_Elt, [k; v], annot) -> + let*? () = + if elab_conf.legacy (* Legacy check introduced before Ithaca. *) + then Result_syntax.return_unit + else error_unexpected_annot loc annot + in + let* k, ctxt = non_terminal_recursion ctxt key_type k in + let* v, ctxt = non_terminal_recursion ctxt value_type v in + let*? ctxt = + let open Result_syntax in + match last_value with + | Some value -> + let* ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare + key_type + value + k) + in + let c = + Script_comparable.compare_comparable key_type value k + in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + tzfail (Duplicate_map_keys (loc, strip_locations expr)) + else + tzfail (Unordered_map_keys (loc, strip_locations expr)) + else return ctxt + | None -> return ctxt + in + let*? ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.map_update k map) + in + return + (Some k, Script_map.update k (Some (item_wrapper v)) map, ctxt) + | Prim (loc, D_Elt, l, _) -> + tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + tzfail @@ Invalid_primitive (loc, [D_Elt], name) + | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) + (None, Script_map.empty key_type, ctxt) + items + |> traced + in + (items, ctxt) + in + let parse_big_map_items (type t) ctxt expr (key_type : t comparable_ty) + value_type items item_wrapper = + let+ _, map, ctxt = + List.fold_left_es + (fun (last_key, {map; size}, ctxt) item -> + match item with + | Prim (loc, D_Elt, [k; v], annot) -> + let*? () = + if elab_conf.legacy (* Legacy check introduced before Ithaca. *) + then Result_syntax.return_unit + else error_unexpected_annot loc annot + in + let* k, ctxt = non_terminal_recursion ctxt key_type k in + let* key_hash, ctxt = hash_comparable_data ctxt key_type k in + let* v, ctxt = non_terminal_recursion ctxt value_type v in + let*? ctxt = + let open Result_syntax in + match last_key with + | Some last_key -> + let* ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare + key_type + last_key + k) + in + let c = + Script_comparable.compare_comparable key_type last_key k + in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + tzfail (Duplicate_map_keys (loc, strip_locations expr)) + else + tzfail (Unordered_map_keys (loc, strip_locations expr)) + else return ctxt + | None -> return ctxt + in + let*? ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.big_map_update + {map; size}) + in + if Big_map_overlay.mem key_hash map then + tzfail (Duplicate_map_keys (loc, strip_locations expr)) + else + return + ( Some k, + { + map = Big_map_overlay.add key_hash (k, item_wrapper v) map; + size = size + 1; + }, + ctxt ) + | Prim (loc, D_Elt, l, _) -> + tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + tzfail @@ Invalid_primitive (loc, [D_Elt], name) + | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) + (None, {map = Big_map_overlay.empty; size = 0}, ctxt) + items + |> traced + in + (map, ctxt) + in + let legacy = elab_conf.legacy in + match (ty, script_data) with + | Unit_t, expr -> + traced_from_gas_monad ctxt + @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) + | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr + | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr + | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr + | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr + | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr + | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr + | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr + | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr + | Key_hash_t, expr -> traced_from_gas_monad ctxt @@ parse_key_hash expr + | Signature_t, expr -> traced_from_gas_monad ctxt @@ parse_signature expr + | Operation_t, _ -> + (* operations cannot appear in parameters or storage, + the protocol should never parse the bytes of an operation *) + assert false + | Chain_id_t, expr -> traced_from_gas_monad ctxt @@ parse_chain_id expr + | Address_t, expr -> + traced_from_gas_monad ctxt + @@ parse_address + ~sc_rollup_enable:elab_conf.sc_rollup_enable + ~zk_rollup_enable:elab_conf.zk_rollup_enable + expr + | Contract_t (arg_ty, _), expr -> + traced + (let*? address, ctxt = + Gas_monad.run ctxt + @@ parse_address + ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) + ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) + expr + in + let*? address in + let loc = location expr in + let+ ctxt, typed_contract = + parse_contract_data + ~stack_depth:(stack_depth + 1) + ctxt + loc + arg_ty + address.destination + ~entrypoint:address.entrypoint + in + (typed_contract, ctxt)) + (* Pairs *) + | Pair_t (tl, tr, _, _), expr -> + let r_witness = comb_witness1 tr in + let parse_l ctxt v = non_terminal_recursion ctxt tl v in + let parse_r ctxt v = non_terminal_recursion ctxt tr v in + traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr + (* Ors *) + | Or_t (tl, tr, _, _), expr -> + let parse_l ctxt v = non_terminal_recursion ctxt tl v in + let parse_r ctxt v = non_terminal_recursion ctxt tr v in + traced @@ parse_or parse_l parse_r ctxt ~legacy expr + (* Lambdas *) + | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> + let* kdescr, ctxt = + traced + @@ parse_kdescr + ~unparse_code_rec + Tc_context.data + ~elab_conf + ~stack_depth:(stack_depth + 1) + ctxt + ta + tr + script_instr + in + (normalized_lam [@ocaml.tailcall]) + ~unparse_code_rec + ctxt + ~stack_depth + kdescr + script_instr + | ( Lambda_t (ta, tr, _ty_name), + Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) -> + traced + @@ let*? lambda_rec_ty = lambda_t loc ta tr in + parse_lam_rec + ~unparse_code_rec + Tc_context.(add_lambda data) + ~elab_conf + ~stack_depth:(stack_depth + 1) + ctxt + ta + tr + lambda_rec_ty + script_instr + | Lambda_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Options *) + | Option_t (t, _, _), expr -> + let parse_v ctxt v = non_terminal_recursion ctxt t v in + traced @@ parse_option parse_v ctxt ~legacy expr + (* Lists *) + | List_t (t, _ty_name), Seq (_loc, items) -> + traced + @@ List.fold_left_es + (fun (rest, ctxt) v -> + let+ v, ctxt = non_terminal_recursion ctxt t v in + (Script_list.cons v rest, ctxt)) + (Script_list.empty, ctxt) + (List.rev items) + | List_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Tickets *) + | Ticket_t (t, _ty_name), expr -> + if allow_forged then + let*? ty = opened_ticket_type (location expr) t in + let* ({destination; entrypoint = _}, (contents, amount)), ctxt = + non_terminal_recursion ctxt ty expr + in + match Ticket_amount.of_n amount with + | Some amount -> ( + match destination with + | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Sc_rollup _ | Zk_rollup _ -> + tzfail (Unexpected_ticket_owner destination)) + | None -> traced_fail Forbidden_zero_ticket_quantity + else traced_fail (Unexpected_forged_value (location expr)) + (* Sets *) + | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> + let+ _, set, ctxt = + traced + @@ List.fold_left_es + (fun (last_value, set, ctxt) v -> + let* v, ctxt = non_terminal_recursion ctxt t v in + let*? ctxt = + let open Result_syntax in + match last_value with + | Some value -> + let* ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare + t + value + v) + in + let c = Script_comparable.compare_comparable t value v in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + tzfail + (Duplicate_set_values (loc, strip_locations expr)) + else + tzfail + (Unordered_set_values (loc, strip_locations expr)) + else return ctxt + | None -> return ctxt + in + let*? ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.set_update v set) + in + return (Some v, Script_set.update v true set, ctxt)) + (None, Script_set.empty t, ctxt) + vs + in + (set, ctxt) + | Set_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Maps *) + | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> + parse_items ctxt expr tk tv vs (fun x -> x) + | Map_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + | Big_map_t (tk, tv, _ty_name), expr -> + let* id_opt, diff, ctxt = + match expr with + | Int (loc, id) -> + return + (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + | Seq (_, vs) -> + let+ diff, ctxt = + parse_big_map_items ctxt expr tk tv vs (fun x -> Some x) + in + (None, diff, ctxt) + | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) -> + let*? () = error_unexpected_annot loc annot in + let*? tv_opt = option_t loc tv in + let+ diff, ctxt = + parse_big_map_items ctxt expr tk tv_opt vs (fun x -> x) + in + (Some (id, loc_id), diff, ctxt) + | Prim (_, D_Pair, [Int _; expr], _) -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + | Prim (_, D_Pair, [expr; _], _) -> + traced_fail (Invalid_kind (location expr, [Int_kind], kind expr)) + | Prim (loc, D_Pair, l, _) -> + traced_fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) + | _ -> + traced_fail + (unexpected expr [Seq_kind; Int_kind] Constant_namespace [D_Pair]) + in + let+ id, ctxt = + match id_opt with + | None -> return (None, ctxt) + | Some (id, loc) -> + if allow_forged then + let id = Big_map.Id.parse_z id in + let* ctxt, tys_opt = Big_map.exists ctxt id in + match tys_opt with + | None -> traced_fail (Invalid_big_map (loc, id)) + | Some (btk, btv) -> + let*? res, ctxt = + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* (Ex_comparable_ty btk) = + parse_comparable_ty + ~stack_depth:(stack_depth + 1) + (Micheline.root btk) + in + let* (Ex_ty btv) = + parse_big_map_value_ty + ~stack_depth:(stack_depth + 1) + ~legacy + (Micheline.root btv) + in + let+ Eq = + let error_details = Informative loc in + let* Eq = ty_eq ~error_details tk btk in + ty_eq ~error_details tv btv + in + Some id + in + let*? res in + return (res, ctxt) + else traced_fail (Unexpected_forged_value loc) + in + (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) + | Never_t, expr -> traced_from_gas_monad ctxt @@ parse_never expr + (* Bls12_381 types *) + | Bls12_381_g1_t, expr -> + traced_from_gas_monad ctxt @@ parse_bls12_381_g1 expr + | Bls12_381_g2_t, expr -> + traced_from_gas_monad ctxt @@ parse_bls12_381_g2 expr + | Bls12_381_fr_t, expr -> + traced_from_gas_monad ctxt @@ parse_bls12_381_fr expr + (* + /!\ When adding new lazy storage kinds, you may want to guard the parsing + of identifiers with [allow_forged]. + *) + (* Sapling *) + | Sapling_transaction_t memo_size, expr -> + traced_from_gas_monad ctxt @@ parse_sapling_transaction ~memo_size expr + | Sapling_transaction_deprecated_t memo_size, expr -> + traced_from_gas_monad ctxt + @@ parse_sapling_transaction_deprecated ~memo_size expr + | Sapling_state_t memo_size, Int (loc, id) -> + if allow_forged then + let id = Sapling.Id.parse_z id in + let* state, ctxt = Sapling.state_from_id ctxt id in + let*? () = + traced_no_lwt + @@ memo_size_eq + ~error_details:(Informative ()) + memo_size + state.Sapling.memo_size + in + return (state, ctxt) + else traced_fail (Unexpected_forged_value loc) + | Sapling_state_t memo_size, Seq (_, []) -> + return (Sapling.empty_state ~memo_size (), ctxt) + | Sapling_state_t _, expr -> + (* Do not allow to input diffs as they are untrusted and may not be the + result of a verify_update. *) + traced_fail + (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) + (* Time lock*) + | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr + | Chest_t, expr -> traced_from_gas_monad ctxt @@ parse_chest expr + let view_size view = let open Script_typed_ir_size in node_size view.view_code ++ node_size view.input_ty @@ -5989,9 +5989,6 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] -let parse_data ~elab_conf ctxt ~allow_forged ty t = - parse_data ~unparse_code_rec ~elab_conf ~allow_forged ~stack_depth:0 ctxt ty t - let parse_view ~elab_conf ctxt ty view = parse_view ~unparse_code_rec ~elab_conf ctxt ty view @@ -6007,15 +6004,6 @@ let parse_storage ~elab_conf ctxt ~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 -let parse_comparable_data ?type_logger ctxt ty t = - parse_data - ~elab_conf: - Script_ir_translator_config.(make ~legacy:false ?type_logger ctxt) - ~allow_forged:false - ctxt - ty - t - let parse_instr : type a s. elab_conf:elab_conf -> @@ -6034,6 +6022,18 @@ let parse_instr : script_instr stack_ty +let parse_data ~elab_conf ctxt ~allow_forged ty t = + parse_data ~unparse_code_rec ~elab_conf ~allow_forged ~stack_depth:0 ctxt ty t + +let parse_comparable_data ?type_logger ctxt ty t = + parse_data + ~elab_conf: + Script_ir_translator_config.(make ~legacy:false ?type_logger ctxt) + ~allow_forged:false + ctxt + ty + t + let unparse_data = unparse_data ~stack_depth:0 let unparse_code ctxt mode code = -- GitLab From e5e1bfd1cb2b3bfcd98d6e6fcff556367a0afe80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 14:56:51 +0200 Subject: [PATCH 03/17] parse_data: ctxt at the end --- .../lib_protocol/script_ir_translator.ml | 14 +++++++------- src/proto_alpha/lib_protocol/script_ir_unparser.ml | 6 +++--- .../lib_protocol/script_ir_unparser.mli | 4 ++-- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 56fe442ab03f..3e2de80f93e3 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2690,10 +2690,10 @@ and parse_instr : ~unparse_code_rec ~elab_conf ~stack_depth:(stack_depth + 1) - ctxt ~allow_forged:false t d + ctxt in let push = {apply = (fun k -> IPush (loc, t, v, k))} in typed ctxt loc push (Item_t (t, stack)) @@ -4695,12 +4695,12 @@ and parse_data : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> elab_conf:elab_conf -> stack_depth:int -> - context -> allow_forged:bool -> (a, ac) ty -> Script.node -> + context -> (a * context) tzresult Lwt.t = - fun ~unparse_code_rec ~elab_conf ~stack_depth ctxt ~allow_forged ty script_data -> + fun ~unparse_code_rec ~elab_conf ~stack_depth ~allow_forged ty script_data ctxt -> let open Lwt_result_syntax in let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in let non_terminal_recursion ctxt ty script_data = @@ -4711,10 +4711,10 @@ and parse_data : ~unparse_code_rec ~elab_conf ~stack_depth:(stack_depth + 1) - ctxt ~allow_forged ty script_data + ctxt in let parse_data_error () = let ty = serialize_ty_for_error ty in @@ -5243,10 +5243,10 @@ let parse_storage : ~unparse_code_rec ~elab_conf ~stack_depth:0 - ctxt ~allow_forged storage_type - (root storage)) + (root storage) + ctxt) let parse_script : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> @@ -6023,7 +6023,7 @@ let parse_instr : stack_ty let parse_data ~elab_conf ctxt ~allow_forged ty t = - parse_data ~unparse_code_rec ~elab_conf ~allow_forged ~stack_depth:0 ctxt ty t + parse_data ~unparse_code_rec ~elab_conf ~allow_forged ~stack_depth:0 ty t ctxt let parse_comparable_data ?type_logger ctxt ty t = parse_data diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 4acddaaca87e..3f04bd2ccc9f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -495,11 +495,11 @@ module type MICHELSON_PARSER = sig unparse_code_rec:unparse_code_rec -> elab_conf:Script_ir_translator_config.elab_config -> stack_depth:int -> - context -> allow_forged:bool -> ('a, 'ac) ty -> Script.node -> - ('a * t) tzresult Lwt.t + context -> + ('a * context) tzresult Lwt.t end module Data_unparser (P : MICHELSON_PARSER) = struct @@ -802,11 +802,11 @@ module Data_unparser (P : MICHELSON_PARSER) = struct P.parse_data ~unparse_code_rec ~elab_conf - ctxt ~stack_depth:(stack_depth + 1) ~allow_forged t data + ctxt in let* data, ctxt = unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode t data diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index f63e77685520..44d199e8c535 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -178,11 +178,11 @@ module type MICHELSON_PARSER = sig unparse_code_rec:unparse_code_rec -> elab_conf:Script_ir_translator_config.elab_config -> stack_depth:int -> - context -> allow_forged:bool -> ('a, 'ac) ty -> Script.node -> - ('a * t) tzresult Lwt.t + context -> + ('a * context) tzresult Lwt.t end module Data_unparser : functor (P : MICHELSON_PARSER) -> sig -- GitLab From 9adf58a36b05642c08fb3347a989852e94007c17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 11:28:08 +0200 Subject: [PATCH 04/17] Parameterize by parse_packable_data --- .../lib_protocol/script_ir_translator.ml | 105 ++++++++++++++++-- 1 file changed, 95 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 3e2de80f93e3..837feeac6c33 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2244,9 +2244,23 @@ let parse_contract_for_script : | Ok res -> Some res | Error Inconsistent_types_fast -> None ) +type parse_packable_data = { + parse_packable_data : + 'a 'ac. + unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + elab_conf:elab_conf -> + stack_depth:int -> + allow_forged:bool -> + ('a, 'ac) ty -> + Script.node -> + context -> + ('a * context) tzresult Lwt.t; +} + let rec parse_view : type storage storagec. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> context -> (storage, storagec) ty -> @@ -2254,6 +2268,7 @@ let rec parse_view : (storage typed_view * context) tzresult Lwt.t = let open Lwt_result_syntax in fun ~unparse_code_rec + ~parse_packable_data ~elab_conf ctxt storage_type @@ -2285,6 +2300,7 @@ let rec parse_view : let* judgement, ctxt = parse_instr ~unparse_code_rec + ~parse_packable_data ~elab_conf ~stack_depth:0 Tc_context.view @@ -2329,26 +2345,34 @@ let rec parse_view : and parse_views : type storage storagec. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> context -> (storage, storagec) ty -> view_map -> (storage typed_view_map * context) tzresult Lwt.t = let open Lwt_result_syntax in - fun ~unparse_code_rec ~elab_conf ctxt storage_type views -> + fun ~unparse_code_rec ~parse_packable_data ~elab_conf ctxt storage_type views -> let aux ctxt name cur_view = let*? ctxt = Gas.consume ctxt (Michelson_v1_gas.Cost_of.Interpreter.view_update name views) in - parse_view ~unparse_code_rec ~elab_conf ctxt storage_type cur_view + parse_view + ~unparse_code_rec + ~parse_packable_data + ~elab_conf + ctxt + storage_type + cur_view in Script_map.map_es_in_context aux ctxt views and parse_kdescr : type arg argc ret retc. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> stack_depth:int -> tc_context -> @@ -2359,6 +2383,7 @@ and parse_kdescr : ((arg, end_of_stack, ret, end_of_stack) kdescr * context) tzresult Lwt.t = let open Lwt_result_syntax in fun ~unparse_code_rec + ~parse_packable_data ~elab_conf ~stack_depth tc_context @@ -2369,6 +2394,7 @@ and parse_kdescr : let* result = parse_instr ~unparse_code_rec + ~parse_packable_data ~elab_conf tc_context ctxt @@ -2404,6 +2430,7 @@ and parse_kdescr : and parse_lam_rec : type arg argc ret retc. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> stack_depth:int -> tc_context -> @@ -2414,6 +2441,7 @@ and parse_lam_rec : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ~unparse_code_rec + ~parse_packable_data ~elab_conf ~stack_depth tc_context @@ -2426,6 +2454,7 @@ and parse_lam_rec : let* result = parse_instr ~unparse_code_rec + ~parse_packable_data ~elab_conf tc_context ctxt @@ -2477,6 +2506,7 @@ and parse_lam_rec : and parse_instr : type a s. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> stack_depth:int -> tc_context -> @@ -2485,6 +2515,7 @@ and parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ~unparse_code_rec + ~parse_packable_data ~elab_conf ~stack_depth tc_context @@ -2534,6 +2565,7 @@ and parse_instr : else parse_instr ~unparse_code_rec + ~parse_packable_data ~elab_conf tc_context ctxt @@ -2686,7 +2718,7 @@ and parse_instr : in let*? (Ex_ty t) = t in let* v, ctxt = - parse_data + parse_packable_data.parse_packable_data ~unparse_code_rec ~elab_conf ~stack_depth:(stack_depth + 1) @@ -3485,6 +3517,7 @@ and parse_instr : let* kdescr, ctxt = parse_kdescr ~unparse_code_rec + ~parse_packable_data (Tc_context.add_lambda tc_context) ~elab_conf ~stack_depth:(stack_depth + 1) @@ -3521,6 +3554,7 @@ and parse_instr : parse_lam_rec ~unparse_code_rec:(fun ctxt ~stack_depth:_ _unparsing_mode node -> return (node, ctxt)) + ~parse_packable_data (* No need to normalize the unparsed component to Optimized mode here because the script is already normalized in Optimized mode. *) Tc_context.(add_lambda tc_context) @@ -4151,6 +4185,7 @@ and parse_instr : (Ill_typed_contract (canonical_code, [])) (parse_kdescr ~unparse_code_rec + ~parse_packable_data (Tc_context.toplevel ~storage_type ~param_type:arg_type @@ -4165,7 +4200,13 @@ and parse_instr : match result with | {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, ctxt -> let views_result = - parse_views ~unparse_code_rec ctxt ~elab_conf storage_type views + parse_views + ~unparse_code_rec + ~parse_packable_data + ctxt + ~elab_conf + storage_type + views in let* _typed_views, ctxt = trace (Ill_typed_contract (canonical_code, [])) views_result @@ -4690,9 +4731,10 @@ and parse_instr : - storage after origination *) -and parse_data : +let rec parse_data_rec : type a ac. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> stack_depth:int -> allow_forged:bool -> @@ -4700,15 +4742,23 @@ and parse_data : Script.node -> context -> (a * context) tzresult Lwt.t = - fun ~unparse_code_rec ~elab_conf ~stack_depth ~allow_forged ty script_data ctxt -> + fun ~unparse_code_rec + ~parse_packable_data + ~elab_conf + ~stack_depth + ~allow_forged + ty + script_data + ctxt -> let open Lwt_result_syntax in let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in let non_terminal_recursion ctxt ty script_data = if Compare.Int.(stack_depth > 10_000) then tzfail Typechecking_too_many_recursive_calls else - parse_data + parse_data_rec ~unparse_code_rec + ~parse_packable_data ~elab_conf ~stack_depth:(stack_depth + 1) ~allow_forged @@ -4917,6 +4967,7 @@ and parse_data : traced @@ parse_kdescr ~unparse_code_rec + ~parse_packable_data Tc_context.data ~elab_conf ~stack_depth:(stack_depth + 1) @@ -4937,6 +4988,7 @@ and parse_data : @@ let*? lambda_rec_ty = lambda_t loc ta tr in parse_lam_rec ~unparse_code_rec + ~parse_packable_data Tc_context.(add_lambda data) ~elab_conf ~stack_depth:(stack_depth + 1) @@ -5131,6 +5183,18 @@ and parse_data : | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr | Chest_t, expr -> traced_from_gas_monad ctxt @@ parse_chest expr +let rec parse_data : + type a ac. + unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + elab_conf:elab_conf -> + stack_depth:int -> + allow_forged:bool -> + (a, ac) ty -> + Script.node -> + context -> + (a * context) tzresult Lwt.t = + parse_data_rec ~parse_packable_data:{parse_packable_data = parse_data} + let view_size view = let open Script_typed_ir_size in node_size view.view_code ++ node_size view.input_ty @@ -5204,6 +5268,7 @@ let parse_code : (Ill_typed_contract (code, [])) (parse_kdescr ~unparse_code_rec + ~parse_packable_data:{parse_packable_data = parse_data} Tc_context.(toplevel ~storage_type ~param_type:arg_type ~entrypoints) ~elab_conf ctxt @@ -5352,6 +5417,7 @@ let typecheck_code : let result = parse_kdescr ~unparse_code_rec + ~parse_packable_data:{parse_packable_data = parse_data} (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints) ctxt ~elab_conf @@ -5364,7 +5430,13 @@ let typecheck_code : trace (Ill_typed_contract (code, !type_map)) result in let views_result = - parse_views ~unparse_code_rec ctxt ~elab_conf storage_type views + parse_views + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data = parse_data} + ctxt + ~elab_conf + storage_type + views in let+ typed_views, ctxt = trace (Ill_typed_contract (code, !type_map)) views_result @@ -5990,10 +6062,22 @@ let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] let parse_view ~elab_conf ctxt ty view = - parse_view ~unparse_code_rec ~elab_conf ctxt ty view + parse_view + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data = parse_data} + ~elab_conf + ctxt + ty + view let parse_views ~elab_conf ctxt ty views = - parse_views ~unparse_code_rec ~elab_conf ctxt ty views + parse_views + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data = parse_data} + ~elab_conf + ctxt + ty + views let parse_code ~elab_conf ctxt ~code = parse_code ~unparse_code_rec ~elab_conf ctxt ~code @@ -6015,6 +6099,7 @@ let parse_instr : fun ~elab_conf tc_context ctxt script_instr stack_ty -> parse_instr ~unparse_code_rec + ~parse_packable_data:{parse_packable_data = parse_data} ~elab_conf ~stack_depth:0 tc_context -- GitLab From 96737bc8646a90575383faa2cfe8c438ed8af3df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 13:04:14 +0200 Subject: [PATCH 05/17] gas monad: list_fold_left --- src/proto_alpha/lib_protocol/gas_monad.ml | 8 ++++++++ src/proto_alpha/lib_protocol/gas_monad.mli | 4 ++++ 2 files changed, 12 insertions(+) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index eebad0580add..a89adbed4fba 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -156,3 +156,11 @@ module Syntax = struct let ( let+$ ) cost f = map f (consume_gas cost) end + +let rec list_fold_left f acc = + let open Syntax in + function + | [] -> return acc + | hd :: tl -> + let* acc = f acc hd in + (list_fold_left [@ocaml.tailcall]) f acc tl diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index 9ecd2d57494b..db86e40499f1 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -94,6 +94,10 @@ val fail : 'trace -> ('a, 'trace) t (** [tzfail e] is [of_result (Result_syntax.tzfail e)] . *) val tzfail : 'err -> ('a, 'err Error_monad.trace) t +(** Folding over a list. *) +val list_fold_left : + ('a -> 'b -> ('a, 'trace) t) -> 'a -> 'b list -> ('a, 'trace) t + (** Syntax module for the {!Gas_monad}. This is intended to be opened locally in functions. Within the scope of this module, the code can include binding operators, leading to a [let]-style syntax. Similar to {!Lwt_result_syntax} -- GitLab From 27ccd8ddc453d333499d8ced67232858239b9111 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 13:04:32 +0200 Subject: [PATCH 06/17] Script_map: map in gas monad --- src/proto_alpha/lib_protocol/script_map.ml | 29 +++++++++++++++++++++ src/proto_alpha/lib_protocol/script_map.mli | 5 ++++ 2 files changed, 34 insertions(+) diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml index d5e5e4e819cd..e9642d3681cb 100644 --- a/src/proto_alpha/lib_protocol/script_map.ml +++ b/src/proto_alpha/lib_protocol/script_map.ml @@ -145,3 +145,32 @@ let map_es_in_context : let size = Box.size end), ctxt ) + +let map_in_gas_monad : + type key value value' trace. + (key -> value -> (value', trace) Gas_monad.t) -> + (key, value) map -> + ((key, value') map, trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun f (Map_tag (module Box)) -> + let+ map = + Box.OPS.fold + (fun key value map -> + let* map in + let+ value = f key value in + Box.OPS.add key value map) + Box.boxed + (return Box.OPS.empty) + in + Map_tag + (module struct + type key = Box.key + + type value = value' + + module OPS = Box.OPS + + let boxed = map + + let size = Box.size + end) diff --git a/src/proto_alpha/lib_protocol/script_map.mli b/src/proto_alpha/lib_protocol/script_map.mli index 23fab2b979b6..8ee87013b706 100644 --- a/src/proto_alpha/lib_protocol/script_map.mli +++ b/src/proto_alpha/lib_protocol/script_map.mli @@ -78,3 +78,8 @@ val map_es_in_context : 'context -> ('key, 'value1) map -> (('key, 'value2) map * 'context) tzresult Lwt.t + +val map_in_gas_monad : + ('key -> 'value1 -> ('value2, 'trace) Gas_monad.t) -> + ('key, 'value1) map -> + (('key, 'value2) map, 'trace) Gas_monad.t -- GitLab From 8f47d3de2f44d959883c6b772a3c7f4c620c2584 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 25 Sep 2023 15:07:14 +0200 Subject: [PATCH 07/17] functorize parse_data --- .../lib_protocol/script_ir_translator.ml | 1107 ++++++++++------- 1 file changed, 672 insertions(+), 435 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 837feeac6c33..b2466cd7fed8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4716,9 +4716,230 @@ and parse_instr : I_XOR; ] -(* -- parse data of any type -- *) +module type GAS_MONAD = sig + type ('a, 'trace) t -(* + val ( let* ) : ('a, 'trace) t -> ('a -> ('b, 'trace) t) -> ('b, 'trace) t + + val ( let+ ) : ('a, 'trace) t -> ('a -> 'b) -> ('b, 'trace) t + + val return : 'a -> ('a, 'trace) t + + val return_unit : (unit, 'trace) t + + val fail : 'trace -> ('a, 'trace) t + + val tzfail : 'err -> ('a, 'err Error_monad.trace) t + + val ( let*? ) : + ('a, 'trace) result -> ('a -> ('b, 'trace) t) -> ('b, 'trace) t + + val ( let*$ ) : + Alpha_context.Gas.cost -> + (unit -> ('a, error trace) t) -> + ('a, error trace) t + + val ( let+$ ) : Alpha_context.Gas.cost -> (unit -> 'a) -> ('a, error trace) t + + val record_trace_eval : + (unit -> error) -> ('a, error trace) t -> ('a, error trace) t + + val from_gas_monad : ('a, error trace) Gas_monad.t -> ('a, error trace) t + + val parse_contract_data : + stack_depth:int -> + Script.location -> + ('arg, 'argc) ty -> + Destination.t -> + 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 + + val list_fold_left : + ('a -> 'b -> ('a, error trace) t) -> 'a -> 'b list -> ('a, error trace) t + + val map_map : + ('key -> 'value1 -> ('value2, error trace) t) -> + ('key, 'value1) map -> + (('key, 'value2) map, error trace) t + + val parse_kdescr : + unparse_code_rec:unparse_code_rec -> + parse_packable_data:parse_packable_data -> + elab_conf:elab_conf -> + stack_depth:int -> + tc_context -> + ('arg, 'argc) ty -> + ('ret, 'retc) ty -> + Script.node -> + (('arg, end_of_stack, 'ret, end_of_stack) kdescr, error trace) t + + val normalized_lam : + unparse_code_rec:unparse_code_rec -> + stack_depth:int -> + ('a, end_of_stack, 'b, end_of_stack) kdescr -> + Script.node -> + (('a, 'b) lambda, error trace) t + + val parse_lam_rec : + unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> + elab_conf:elab_conf -> + stack_depth:int -> + tc_context -> + ('arg, 'argc) ty -> + ('ret, 'retc) ty -> + (('arg, 'ret) lambda, Dependent_bool.no) ty -> + Script.node -> + (('arg, 'ret) lambda, error trace) t +end + +module GM : GAS_MONAD with type ('a, 'trace) t = ('a, 'trace) Gas_monad.t = +struct + include Gas_monad.Syntax + + type ('a, 'trace) t = ('a, 'trace) Gas_monad.t + + let record_trace_eval x = + Gas_monad.record_trace_eval ~error_details:(Informative ()) x + + let from_gas_monad g = g + + let parse_contract_data ~stack_depth:_ _loc _ty _dest ~entrypoint:_ = + assert false + + let hash_comparable_data _ty _x = assert false + + let big_map_exists _id = assert false + + let sapling_state_from_id _id = assert false + + let list_fold_left = Gas_monad.list_fold_left + + let map_map = Script_map.map_in_gas_monad + + let parse_kdescr ~unparse_code_rec:_ ~parse_packable_data:_ ~elab_conf:_ + ~stack_depth:_ _tc_context _ta _tr _node = + assert false + + let normalized_lam ~unparse_code_rec:_ ~stack_depth:_ _kdescr _script_instr = + assert false + + let parse_lam_rec ~unparse_code_rec:_ ~parse_packable_data:_ ~elab_conf:_ + ~stack_depth:_ _tc_context _arg_ty _ret_ty _lam_ty _node = + assert false +end + +module LGM : + GAS_MONAD + with type ('a, 'trace) t = context -> ('a * context, 'trace) result Lwt.t = +struct + type ('a, 'trace) t = context -> ('a * context, 'trace) result Lwt.t + + let ( let* ) m f ctxt = + let open Lwt_result_syntax in + let* x, ctxt = m ctxt in + f x ctxt + + let ( let+ ) m f ctxt = + let open Lwt_result_syntax in + let+ x, ctxt = m ctxt in + (f x, ctxt) + + let return x ctxt = Lwt_result_syntax.return (x, ctxt) + + let return_unit ctxt = Lwt_result_syntax.return ((), ctxt) + + let fail trace _ctxt = Lwt_result_syntax.fail trace + + let tzfail trace _ctxt = Lwt_result_syntax.tzfail trace + + let ( let*$ ) cost f ctxt = + let open Lwt_result_syntax in + let*? ctxt = Gas.consume ctxt cost in + f () ctxt + + let ( let+$ ) cost f ctxt = + let open Lwt_result_syntax in + let*? ctxt = Gas.consume ctxt cost in + return (f (), ctxt) + + let ( let*? ) m f ctxt = + let open Lwt_result_syntax in + let*? x = m in + f x ctxt + + let record_trace_eval f res ctxt = trace_eval f (res ctxt) + + let from_gas_monad g ctxt = + let open Lwt_result_syntax in + let*? res, ctxt = Gas_monad.run ctxt g in + let*? res in + return (res, ctxt) + + let parse_contract_data ~stack_depth loc ty addr ~entrypoint ctxt = + let open Lwt_result_syntax in + let+ ctxt, res = + parse_contract_data ctxt ~stack_depth loc ty addr ~entrypoint + 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 + (res, ctxt) + + let sapling_state_from_id id ctxt = Sapling.state_from_id ctxt id + + let list_fold_left f acc l ctxt = + List.fold_left_es (fun (acc, ctxt) x -> f acc x ctxt) (acc, ctxt) l + + let map_map f m ctxt = + Script_map.map_es_in_context (fun ctxt k v -> f k v ctxt) ctxt m + + let parse_kdescr ~unparse_code_rec ~parse_packable_data ~elab_conf + ~stack_depth tc_context ta tr node ctxt = + parse_kdescr + ~unparse_code_rec + ~parse_packable_data + ~elab_conf + ~stack_depth + tc_context + ctxt + ta + tr + node + + let normalized_lam ~unparse_code_rec ~stack_depth kdescr script_instr ctxt = + normalized_lam ~unparse_code_rec ~stack_depth ctxt kdescr script_instr + + let parse_lam_rec ~unparse_code_rec ~parse_packable_data ~elab_conf + ~stack_depth tc_context arg_ty ret_ty lam_ty node ctxt = + parse_lam_rec + ~unparse_code_rec + ~parse_packable_data + ~elab_conf + ~stack_depth + tc_context + ctxt + arg_ty + ret_ty + lam_ty + node +end + +module Parse_data (M : GAS_MONAD) = struct + (* -- parse data of any type -- *) + + (* Some values, such as operations, tickets, or big map ids, are used only internally and are not allowed to be forged by users. In [parse_data], [allow_forged] should be [false] for: @@ -4731,457 +4952,473 @@ and parse_instr : - storage after origination *) -let rec parse_data_rec : - type a ac. - unparse_code_rec:Script_ir_unparser.unparse_code_rec -> - parse_packable_data:parse_packable_data -> - elab_conf:elab_conf -> - stack_depth:int -> - allow_forged:bool -> - (a, ac) ty -> - Script.node -> - context -> - (a * context) tzresult Lwt.t = - fun ~unparse_code_rec - ~parse_packable_data - ~elab_conf - ~stack_depth - ~allow_forged - ty - script_data - ctxt -> - let open Lwt_result_syntax in - let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in - let non_terminal_recursion ctxt ty script_data = - if Compare.Int.(stack_depth > 10_000) then - tzfail Typechecking_too_many_recursive_calls - else - parse_data_rec - ~unparse_code_rec - ~parse_packable_data - ~elab_conf - ~stack_depth:(stack_depth + 1) - ~allow_forged - ty - script_data - ctxt - in - let parse_data_error () = - let ty = serialize_ty_for_error ty in - Invalid_constant (location script_data, strip_locations script_data, ty) - in - let fail_parse_data () = tzfail (parse_data_error ()) in - let traced_no_lwt body = record_trace_eval parse_data_error body in - let traced body = trace_eval parse_data_error body in - let traced_from_gas_monad ctxt body = - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - let* res, ctxt = Gas_monad.run ctxt body in - let+ res in - (res, ctxt) - in - let traced_fail err = - Lwt.return @@ traced_no_lwt (Result_syntax.tzfail err) - in - let parse_items ctxt expr key_type value_type items item_wrapper = - let+ _, items, ctxt = - List.fold_left_es - (fun (last_value, map, ctxt) item -> - match item with - | Prim (loc, D_Elt, [k; v], annot) -> - let*? () = - if elab_conf.legacy (* Legacy check introduced before Ithaca. *) - then Result_syntax.return_unit - else error_unexpected_annot loc annot - in - let* k, ctxt = non_terminal_recursion ctxt key_type k in - let* v, ctxt = non_terminal_recursion ctxt value_type v in - let*? ctxt = - let open Result_syntax in - match last_value with - | Some value -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - key_type - value - k) - in - let c = - Script_comparable.compare_comparable key_type value k - in - if Compare.Int.(0 <= c) then - if Compare.Int.(0 = c) then - tzfail (Duplicate_map_keys (loc, strip_locations expr)) - else - tzfail (Unordered_map_keys (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt - in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.map_update k map) - in - return - (Some k, Script_map.update k (Some (item_wrapper v)) map, ctxt) - | Prim (loc, D_Elt, l, _) -> - tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) - | Prim (loc, name, _, _) -> - tzfail @@ Invalid_primitive (loc, [D_Elt], name) - | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) - (None, Script_map.empty key_type, ctxt) - items - |> traced + let rec parse_data_rec : + type a ac. + unparse_code_rec:Script_ir_unparser.unparse_code_rec -> + parse_packable_data:parse_packable_data -> + elab_conf:elab_conf -> + stack_depth:int -> + allow_forged:bool -> + (a, ac) ty -> + Script.node -> + context -> + (a * context) tzresult Lwt.t = + fun ~unparse_code_rec + ~parse_packable_data + ~elab_conf + ~stack_depth + ~allow_forged + ty + script_data + ctxt -> + let open Lwt_result_syntax in + let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in + let non_terminal_recursion ctxt ty script_data = + if Compare.Int.(stack_depth > 10_000) then + tzfail Typechecking_too_many_recursive_calls + else + parse_data_rec + ~unparse_code_rec + ~parse_packable_data + ~elab_conf + ~stack_depth:(stack_depth + 1) + ~allow_forged + ty + script_data + ctxt in - (items, ctxt) - in - let parse_big_map_items (type t) ctxt expr (key_type : t comparable_ty) - value_type items item_wrapper = - let+ _, map, ctxt = - List.fold_left_es - (fun (last_key, {map; size}, ctxt) item -> - match item with - | Prim (loc, D_Elt, [k; v], annot) -> - let*? () = - if elab_conf.legacy (* Legacy check introduced before Ithaca. *) - then Result_syntax.return_unit - else error_unexpected_annot loc annot - in - let* k, ctxt = non_terminal_recursion ctxt key_type k in - let* key_hash, ctxt = hash_comparable_data ctxt key_type k in - let* v, ctxt = non_terminal_recursion ctxt value_type v in - let*? ctxt = - let open Result_syntax in - match last_key with - | Some last_key -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - key_type - last_key - k) - in - let c = - Script_comparable.compare_comparable key_type last_key k - in - if Compare.Int.(0 <= c) then - if Compare.Int.(0 = c) then - tzfail (Duplicate_map_keys (loc, strip_locations expr)) - else - tzfail (Unordered_map_keys (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt - in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.big_map_update - {map; size}) - in - if Big_map_overlay.mem key_hash map then - tzfail (Duplicate_map_keys (loc, strip_locations expr)) - else + let parse_data_error () = + let ty = serialize_ty_for_error ty in + Invalid_constant (location script_data, strip_locations script_data, ty) + in + let fail_parse_data () = tzfail (parse_data_error ()) in + let traced_no_lwt body = record_trace_eval parse_data_error body in + let traced body = trace_eval parse_data_error body in + let traced_from_gas_monad ctxt body = + Lwt.return @@ traced_no_lwt + @@ + let open Result_syntax in + let* res, ctxt = Gas_monad.run ctxt body in + let+ res in + (res, ctxt) + in + let traced_fail err = + Lwt.return @@ traced_no_lwt (Result_syntax.tzfail err) + in + let parse_items ctxt expr key_type value_type items item_wrapper = + let+ _, items, ctxt = + List.fold_left_es + (fun (last_value, map, ctxt) item -> + match item with + | Prim (loc, D_Elt, [k; v], annot) -> + let*? () = + if + elab_conf.legacy + (* Legacy check introduced before Ithaca. *) + then Result_syntax.return_unit + else error_unexpected_annot loc annot + in + let* k, ctxt = non_terminal_recursion ctxt key_type k in + let* v, ctxt = non_terminal_recursion ctxt value_type v in + let*? ctxt = + let open Result_syntax in + match last_value with + | Some value -> + let* ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare + key_type + value + k) + in + let c = + Script_comparable.compare_comparable key_type value k + in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + tzfail + (Duplicate_map_keys (loc, strip_locations expr)) + else + tzfail + (Unordered_map_keys (loc, strip_locations expr)) + else return ctxt + | None -> return ctxt + in + let*? ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.map_update k map) + in return - ( Some k, - { - map = Big_map_overlay.add key_hash (k, item_wrapper v) map; - size = size + 1; - }, - ctxt ) - | Prim (loc, D_Elt, l, _) -> - tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) - | Prim (loc, name, _, _) -> - tzfail @@ Invalid_primitive (loc, [D_Elt], name) - | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) - (None, {map = Big_map_overlay.empty; size = 0}, ctxt) - items - |> traced + (Some k, Script_map.update k (Some (item_wrapper v)) map, ctxt) + | Prim (loc, D_Elt, l, _) -> + tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + tzfail @@ Invalid_primitive (loc, [D_Elt], name) + | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) + (None, Script_map.empty key_type, ctxt) + items + |> traced + in + (items, ctxt) in - (map, ctxt) - in - let legacy = elab_conf.legacy in - match (ty, script_data) with - | Unit_t, expr -> - traced_from_gas_monad ctxt - @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) - | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr - | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr - | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr - | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr - | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr - | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr - | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr - | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr - | Key_hash_t, expr -> traced_from_gas_monad ctxt @@ parse_key_hash expr - | Signature_t, expr -> traced_from_gas_monad ctxt @@ parse_signature expr - | Operation_t, _ -> - (* operations cannot appear in parameters or storage, - the protocol should never parse the bytes of an operation *) - assert false - | Chain_id_t, expr -> traced_from_gas_monad ctxt @@ parse_chain_id expr - | Address_t, expr -> - traced_from_gas_monad ctxt - @@ parse_address - ~sc_rollup_enable:elab_conf.sc_rollup_enable - ~zk_rollup_enable:elab_conf.zk_rollup_enable - expr - | Contract_t (arg_ty, _), expr -> - traced - (let*? address, ctxt = - Gas_monad.run ctxt - @@ parse_address - ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) - ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) - expr - in - let*? address in - let loc = location expr in - let+ ctxt, typed_contract = - parse_contract_data - ~stack_depth:(stack_depth + 1) - ctxt - loc - arg_ty - address.destination - ~entrypoint:address.entrypoint - in - (typed_contract, ctxt)) - (* Pairs *) - | Pair_t (tl, tr, _, _), expr -> - let r_witness = comb_witness1 tr in - let parse_l ctxt v = non_terminal_recursion ctxt tl v in - let parse_r ctxt v = non_terminal_recursion ctxt tr v in - traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr - (* Ors *) - | Or_t (tl, tr, _, _), expr -> - let parse_l ctxt v = non_terminal_recursion ctxt tl v in - let parse_r ctxt v = non_terminal_recursion ctxt tr v in - traced @@ parse_or parse_l parse_r ctxt ~legacy expr - (* Lambdas *) - | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> - let* kdescr, ctxt = + let parse_big_map_items (type t) ctxt expr (key_type : t comparable_ty) + value_type items item_wrapper = + let+ _, map, ctxt = + List.fold_left_es + (fun (last_key, {map; size}, ctxt) item -> + match item with + | Prim (loc, D_Elt, [k; v], annot) -> + let*? () = + if + elab_conf.legacy + (* Legacy check introduced before Ithaca. *) + then Result_syntax.return_unit + else error_unexpected_annot loc annot + in + let* k, ctxt = non_terminal_recursion ctxt key_type k in + let* key_hash, ctxt = hash_comparable_data ctxt key_type k in + let* v, ctxt = non_terminal_recursion ctxt value_type v in + let*? ctxt = + let open Result_syntax in + match last_key with + | Some last_key -> + let* ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare + key_type + last_key + k) + in + let c = + Script_comparable.compare_comparable key_type last_key k + in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + tzfail + (Duplicate_map_keys (loc, strip_locations expr)) + else + tzfail + (Unordered_map_keys (loc, strip_locations expr)) + else return ctxt + | None -> return ctxt + in + let*? ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.big_map_update + {map; size}) + in + if Big_map_overlay.mem key_hash map then + tzfail (Duplicate_map_keys (loc, strip_locations expr)) + else + return + ( Some k, + { + map = + Big_map_overlay.add key_hash (k, item_wrapper v) map; + size = size + 1; + }, + ctxt ) + | Prim (loc, D_Elt, l, _) -> + tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) + | Prim (loc, name, _, _) -> + tzfail @@ Invalid_primitive (loc, [D_Elt], name) + | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) + (None, {map = Big_map_overlay.empty; size = 0}, ctxt) + items + |> traced + in + (map, ctxt) + in + let legacy = elab_conf.legacy in + match (ty, script_data) with + | Unit_t, expr -> + traced_from_gas_monad ctxt + @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) + | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr + | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr + | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr + | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr + | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr + | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr + | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr + | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr + | Key_hash_t, expr -> traced_from_gas_monad ctxt @@ parse_key_hash expr + | Signature_t, expr -> traced_from_gas_monad ctxt @@ parse_signature expr + | Operation_t, _ -> + (* operations cannot appear in parameters or storage, + the protocol should never parse the bytes of an operation *) + assert false + | Chain_id_t, expr -> traced_from_gas_monad ctxt @@ parse_chain_id expr + | Address_t, expr -> + traced_from_gas_monad ctxt + @@ parse_address + ~sc_rollup_enable:elab_conf.sc_rollup_enable + ~zk_rollup_enable:elab_conf.zk_rollup_enable + expr + | Contract_t (arg_ty, _), expr -> traced - @@ parse_kdescr + (let*? address, ctxt = + Gas_monad.run ctxt + @@ parse_address + ~sc_rollup_enable:(Constants.sc_rollup_enable ctxt) + ~zk_rollup_enable:(Constants.zk_rollup_enable ctxt) + expr + in + let*? address in + let loc = location expr in + let+ ctxt, typed_contract = + parse_contract_data + ~stack_depth:(stack_depth + 1) + ctxt + loc + arg_ty + address.destination + ~entrypoint:address.entrypoint + in + (typed_contract, ctxt)) + (* Pairs *) + | Pair_t (tl, tr, _, _), expr -> + let r_witness = comb_witness1 tr in + let parse_l ctxt v = non_terminal_recursion ctxt tl v in + let parse_r ctxt v = non_terminal_recursion ctxt tr v in + traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr + (* Ors *) + | Or_t (tl, tr, _, _), expr -> + let parse_l ctxt v = non_terminal_recursion ctxt tl v in + let parse_r ctxt v = non_terminal_recursion ctxt tr v in + traced @@ parse_or parse_l parse_r ctxt ~legacy expr + (* Lambdas *) + | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> + let* kdescr, ctxt = + traced + @@ parse_kdescr + ~unparse_code_rec + ~parse_packable_data + Tc_context.data + ~elab_conf + ~stack_depth:(stack_depth + 1) + ctxt + ta + tr + script_instr + in + (normalized_lam [@ocaml.tailcall]) + ~unparse_code_rec + ctxt + ~stack_depth + kdescr + script_instr + | ( Lambda_t (ta, tr, _ty_name), + Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) -> + traced + @@ let*? lambda_rec_ty = lambda_t loc ta tr in + parse_lam_rec ~unparse_code_rec ~parse_packable_data - Tc_context.data + Tc_context.(add_lambda data) ~elab_conf ~stack_depth:(stack_depth + 1) ctxt ta tr + lambda_rec_ty script_instr - in - (normalized_lam [@ocaml.tailcall]) - ~unparse_code_rec - ctxt - ~stack_depth - kdescr - script_instr - | ( Lambda_t (ta, tr, _ty_name), - Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) -> - traced - @@ let*? lambda_rec_ty = lambda_t loc ta tr in - parse_lam_rec - ~unparse_code_rec - ~parse_packable_data - Tc_context.(add_lambda data) - ~elab_conf - ~stack_depth:(stack_depth + 1) - ctxt - ta - tr - lambda_rec_ty - script_instr - | Lambda_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - (* Options *) - | Option_t (t, _, _), expr -> - let parse_v ctxt v = non_terminal_recursion ctxt t v in - traced @@ parse_option parse_v ctxt ~legacy expr - (* Lists *) - | List_t (t, _ty_name), Seq (_loc, items) -> - traced - @@ List.fold_left_es - (fun (rest, ctxt) v -> - let+ v, ctxt = non_terminal_recursion ctxt t v in - (Script_list.cons v rest, ctxt)) - (Script_list.empty, ctxt) - (List.rev items) - | List_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - (* Tickets *) - | Ticket_t (t, _ty_name), expr -> - if allow_forged then - let*? ty = opened_ticket_type (location expr) t in - let* ({destination; entrypoint = _}, (contents, amount)), ctxt = - non_terminal_recursion ctxt ty expr - in - match Ticket_amount.of_n amount with - | Some amount -> ( - match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) - | Sc_rollup _ | Zk_rollup _ -> - tzfail (Unexpected_ticket_owner destination)) - | None -> traced_fail Forbidden_zero_ticket_quantity - else traced_fail (Unexpected_forged_value (location expr)) - (* Sets *) - | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> - let+ _, set, ctxt = + | Lambda_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Options *) + | Option_t (t, _, _), expr -> + let parse_v ctxt v = non_terminal_recursion ctxt t v in + traced @@ parse_option parse_v ctxt ~legacy expr + (* Lists *) + | List_t (t, _ty_name), Seq (_loc, items) -> traced @@ List.fold_left_es - (fun (last_value, set, ctxt) v -> - let* v, ctxt = non_terminal_recursion ctxt t v in - let*? ctxt = - let open Result_syntax in - match last_value with - | Some value -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - t - value - v) - in - let c = Script_comparable.compare_comparable t value v in - if Compare.Int.(0 <= c) then - if Compare.Int.(0 = c) then - tzfail - (Duplicate_set_values (loc, strip_locations expr)) - else - tzfail - (Unordered_set_values (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt - in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.set_update v set) - in - return (Some v, Script_set.update v true set, ctxt)) - (None, Script_set.empty t, ctxt) - vs - in - (set, ctxt) - | Set_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - (* Maps *) - | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - parse_items ctxt expr tk tv vs (fun x -> x) - | Map_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - | Big_map_t (tk, tv, _ty_name), expr -> - let* id_opt, diff, ctxt = - match expr with - | Int (loc, id) -> - return - (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) - | Seq (_, vs) -> - let+ diff, ctxt = - parse_big_map_items ctxt expr tk tv vs (fun x -> Some x) - in - (None, diff, ctxt) - | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) -> - let*? () = error_unexpected_annot loc annot in - let*? tv_opt = option_t loc tv in - let+ diff, ctxt = - parse_big_map_items ctxt expr tk tv_opt vs (fun x -> x) - in - (Some (id, loc_id), diff, ctxt) - | Prim (_, D_Pair, [Int _; expr], _) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) - | Prim (_, D_Pair, [expr; _], _) -> - traced_fail (Invalid_kind (location expr, [Int_kind], kind expr)) - | Prim (loc, D_Pair, l, _) -> - traced_fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) - | _ -> - traced_fail - (unexpected expr [Seq_kind; Int_kind] Constant_namespace [D_Pair]) - in - let+ id, ctxt = - match id_opt with - | None -> return (None, ctxt) - | Some (id, loc) -> - if allow_forged then - let id = Big_map.Id.parse_z id in - let* ctxt, tys_opt = Big_map.exists ctxt id in - match tys_opt with - | None -> traced_fail (Invalid_big_map (loc, id)) - | Some (btk, btv) -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* (Ex_comparable_ty btk) = - parse_comparable_ty - ~stack_depth:(stack_depth + 1) - (Micheline.root btk) - in - let* (Ex_ty btv) = - parse_big_map_value_ty - ~stack_depth:(stack_depth + 1) - ~legacy - (Micheline.root btv) - in - let+ Eq = - let error_details = Informative loc in - let* Eq = ty_eq ~error_details tk btk in - ty_eq ~error_details tv btv + (fun (rest, ctxt) v -> + let+ v, ctxt = non_terminal_recursion ctxt t v in + (Script_list.cons v rest, ctxt)) + (Script_list.empty, ctxt) + (List.rev items) + | List_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Tickets *) + | Ticket_t (t, _ty_name), expr -> + if allow_forged then + let*? ty = opened_ticket_type (location expr) t in + let* ({destination; entrypoint = _}, (contents, amount)), ctxt = + non_terminal_recursion ctxt ty expr + in + match Ticket_amount.of_n amount with + | Some amount -> ( + match destination with + | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Sc_rollup _ | Zk_rollup _ -> + tzfail (Unexpected_ticket_owner destination)) + | None -> traced_fail Forbidden_zero_ticket_quantity + else traced_fail (Unexpected_forged_value (location expr)) + (* Sets *) + | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> + let+ _, set, ctxt = + traced + @@ List.fold_left_es + (fun (last_value, set, ctxt) v -> + let* v, ctxt = non_terminal_recursion ctxt t v in + let*? ctxt = + let open Result_syntax in + match last_value with + | Some value -> + let* ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.compare + t + value + v) + in + let c = Script_comparable.compare_comparable t value v in + if Compare.Int.(0 <= c) then + if Compare.Int.(0 = c) then + tzfail + (Duplicate_set_values (loc, strip_locations expr)) + else + tzfail + (Unordered_set_values (loc, strip_locations expr)) + else return ctxt + | None -> return ctxt + in + let*? ctxt = + Gas.consume + ctxt + (Michelson_v1_gas.Cost_of.Interpreter.set_update v set) + in + return (Some v, Script_set.update v true set, ctxt)) + (None, Script_set.empty t, ctxt) + vs + in + (set, ctxt) + | Set_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (* Maps *) + | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> + parse_items ctxt expr tk tv vs (fun x -> x) + | Map_t _, expr -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + | Big_map_t (tk, tv, _ty_name), expr -> + let* id_opt, diff, ctxt = + match expr with + | Int (loc, id) -> + return + (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + | Seq (_, vs) -> + let+ diff, ctxt = + parse_big_map_items ctxt expr tk tv vs (fun x -> Some x) + in + (None, diff, ctxt) + | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) -> + let*? () = error_unexpected_annot loc annot in + let*? tv_opt = option_t loc tv in + let+ diff, ctxt = + parse_big_map_items ctxt expr tk tv_opt vs (fun x -> x) + in + (Some (id, loc_id), diff, ctxt) + | Prim (_, D_Pair, [Int _; expr], _) -> + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + | Prim (_, D_Pair, [expr; _], _) -> + traced_fail (Invalid_kind (location expr, [Int_kind], kind expr)) + | Prim (loc, D_Pair, l, _) -> + traced_fail @@ Invalid_arity (loc, D_Pair, 2, List.length l) + | _ -> + traced_fail + (unexpected + expr + [Seq_kind; Int_kind] + Constant_namespace + [D_Pair]) + in + let+ id, ctxt = + match id_opt with + | None -> return (None, ctxt) + | Some (id, loc) -> + if allow_forged then + let id = Big_map.Id.parse_z id in + let* ctxt, tys_opt = Big_map.exists ctxt id in + match tys_opt with + | None -> traced_fail (Invalid_big_map (loc, id)) + | Some (btk, btv) -> + let*? res, ctxt = + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* (Ex_comparable_ty btk) = + parse_comparable_ty + ~stack_depth:(stack_depth + 1) + (Micheline.root btk) + in + let* (Ex_ty btv) = + parse_big_map_value_ty + ~stack_depth:(stack_depth + 1) + ~legacy + (Micheline.root btv) + in + let+ Eq = + let error_details = Informative loc in + let* Eq = ty_eq ~error_details tk btk in + ty_eq ~error_details tv btv + in + Some id in - Some id - in - let*? res in - return (res, ctxt) - else traced_fail (Unexpected_forged_value loc) - in - (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) - | Never_t, expr -> traced_from_gas_monad ctxt @@ parse_never expr - (* Bls12_381 types *) - | Bls12_381_g1_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_g1 expr - | Bls12_381_g2_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_g2 expr - | Bls12_381_fr_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_fr expr - (* + let*? res in + return (res, ctxt) + else traced_fail (Unexpected_forged_value loc) + in + (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) + | Never_t, expr -> traced_from_gas_monad ctxt @@ parse_never expr + (* Bls12_381 types *) + | Bls12_381_g1_t, expr -> + traced_from_gas_monad ctxt @@ parse_bls12_381_g1 expr + | Bls12_381_g2_t, expr -> + traced_from_gas_monad ctxt @@ parse_bls12_381_g2 expr + | Bls12_381_fr_t, expr -> + traced_from_gas_monad ctxt @@ parse_bls12_381_fr expr + (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. *) - (* Sapling *) - | Sapling_transaction_t memo_size, expr -> - traced_from_gas_monad ctxt @@ parse_sapling_transaction ~memo_size expr - | Sapling_transaction_deprecated_t memo_size, expr -> - traced_from_gas_monad ctxt - @@ parse_sapling_transaction_deprecated ~memo_size expr - | Sapling_state_t memo_size, Int (loc, id) -> - if allow_forged then - let id = Sapling.Id.parse_z id in - let* state, ctxt = Sapling.state_from_id ctxt id in - let*? () = - traced_no_lwt - @@ memo_size_eq - ~error_details:(Informative ()) - memo_size - state.Sapling.memo_size - in - return (state, ctxt) - else traced_fail (Unexpected_forged_value loc) - | Sapling_state_t memo_size, Seq (_, []) -> - return (Sapling.empty_state ~memo_size (), ctxt) - | Sapling_state_t _, expr -> - (* Do not allow to input diffs as they are untrusted and may not be the - result of a verify_update. *) - traced_fail - (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) - (* Time lock*) - | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr - | Chest_t, expr -> traced_from_gas_monad ctxt @@ parse_chest expr + (* Sapling *) + | Sapling_transaction_t memo_size, expr -> + traced_from_gas_monad ctxt @@ parse_sapling_transaction ~memo_size expr + | Sapling_transaction_deprecated_t memo_size, expr -> + traced_from_gas_monad ctxt + @@ parse_sapling_transaction_deprecated ~memo_size expr + | Sapling_state_t memo_size, Int (loc, id) -> + if allow_forged then + let id = Sapling.Id.parse_z id in + let* state, ctxt = Sapling.state_from_id ctxt id in + let*? () = + traced_no_lwt + @@ memo_size_eq + ~error_details:(Informative ()) + memo_size + state.Sapling.memo_size + in + return (state, ctxt) + else traced_fail (Unexpected_forged_value loc) + | Sapling_state_t memo_size, Seq (_, []) -> + return (Sapling.empty_state ~memo_size (), ctxt) + | Sapling_state_t _, expr -> + (* Do not allow to input diffs as they are untrusted and may not be the + result of a verify_update. *) + traced_fail + (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) + (* Time lock*) + | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr + | Chest_t, expr -> traced_from_gas_monad ctxt @@ parse_chest expr +end + +open Parse_data (LGM) let rec parse_data : type a ac. -- GitLab From 93f627f2e78f6343ea0570a9505e33bebda12f05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 15:27:11 +0200 Subject: [PATCH 08/17] move parse_{pair,or,option} --- .../lib_protocol/script_ir_translator.ml | 168 +++++++++--------- 1 file changed, 84 insertions(+), 84 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b2466cd7fed8..b72a44f0c17e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1824,90 +1824,6 @@ let parse_chest : (* -- parse data of complex types -- *) -let parse_pair (type r) parse_l parse_r ctxt ~legacy - (r_comb_witness : (r, unit -> _) comb_witness) expr = - let open Lwt_result_syntax in - let parse_comb loc l rs = - let* l, ctxt = parse_l ctxt l in - let*? r = - match (rs, r_comb_witness) with - | [r], _ -> Ok r - | [], _ -> Result_syntax.tzfail @@ Invalid_arity (loc, D_Pair, 2, 1) - | _ :: _, Comb_Pair _ -> - (* Unfold [Pair x1 ... xn] as [Pair x1 (Pair x2 ... xn-1 xn))] - for type [pair ta (pair tb1 tb2)] and n >= 3 only *) - Ok (Prim (loc, D_Pair, rs, [])) - | _ -> - Result_syntax.tzfail - @@ Invalid_arity (loc, D_Pair, 2, 1 + List.length rs) - in - let+ r, ctxt = parse_r ctxt r in - ((l, r), ctxt) - in - match expr with - | Prim (loc, D_Pair, l :: rs, annot) -> - let*? () = - if legacy (* Legacy check introduced before Ithaca. *) then - Result_syntax.return_unit - else error_unexpected_annot loc annot - in - parse_comb loc l rs - | Prim (loc, D_Pair, l, _) -> - tzfail @@ Invalid_arity (loc, D_Pair, 2, List.length l) - (* Unfold [{x1; ...; xn}] as [Pair x1 x2 ... xn-1 xn] for n >= 2 *) - | Seq (loc, l :: (_ :: _ as rs)) -> parse_comb loc l rs - | Seq (loc, l) -> tzfail @@ Invalid_seq_arity (loc, 2, List.length l) - | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Pair] - -let parse_or parse_l parse_r ctxt ~legacy = - let open Lwt_result_syntax in - function - | Prim (loc, D_Left, [v], annot) -> - let*? () = - if legacy (* Legacy check introduced before Ithaca. *) then - Result_syntax.return_unit - else error_unexpected_annot loc annot - in - let+ v, ctxt = parse_l ctxt v in - (L v, ctxt) - | Prim (loc, D_Left, l, _) -> - tzfail @@ Invalid_arity (loc, D_Left, 1, List.length l) - | Prim (loc, D_Right, [v], annot) -> - let*? () = - if legacy (* Legacy check introduced before Ithaca. *) then - Result_syntax.return_unit - else error_unexpected_annot loc annot - in - let+ v, ctxt = parse_r ctxt v in - (R v, ctxt) - | Prim (loc, D_Right, l, _) -> - tzfail @@ Invalid_arity (loc, D_Right, 1, List.length l) - | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Left; D_Right] - -let parse_option parse_v ctxt ~legacy = - let open Lwt_result_syntax in - function - | Prim (loc, D_Some, [v], annot) -> - let*? () = - if legacy (* Legacy check introduced before Ithaca. *) then - Result_syntax.return_unit - else error_unexpected_annot loc annot - in - let+ v, ctxt = parse_v ctxt v in - (Some v, ctxt) - | Prim (loc, D_Some, l, _) -> - tzfail @@ Invalid_arity (loc, D_Some, 1, List.length l) - | Prim (loc, D_None, [], annot) -> - let*? () = - if legacy (* Legacy check introduced before Ithaca. *) then - Result_syntax.return_unit - else error_unexpected_annot loc annot - in - return (None, ctxt) - | Prim (loc, D_None, l, _) -> - tzfail @@ Invalid_arity (loc, D_None, 0, List.length l) - | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Some; D_None] - let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = function | Pair_t _ -> Comb_Pair Comb_Any @@ -4937,6 +4853,90 @@ struct end module Parse_data (M : GAS_MONAD) = struct + let parse_pair (type r) parse_l parse_r ctxt ~legacy + (r_comb_witness : (r, unit -> _) comb_witness) expr = + let open Lwt_result_syntax in + let parse_comb loc l rs = + let* l, ctxt = parse_l ctxt l in + let*? r = + match (rs, r_comb_witness) with + | [r], _ -> Ok r + | [], _ -> Result_syntax.tzfail @@ Invalid_arity (loc, D_Pair, 2, 1) + | _ :: _, Comb_Pair _ -> + (* Unfold [Pair x1 ... xn] as [Pair x1 (Pair x2 ... xn-1 xn))] + for type [pair ta (pair tb1 tb2)] and n >= 3 only *) + Ok (Prim (loc, D_Pair, rs, [])) + | _ -> + Result_syntax.tzfail + @@ Invalid_arity (loc, D_Pair, 2, 1 + List.length rs) + in + let+ r, ctxt = parse_r ctxt r in + ((l, r), ctxt) + in + match expr with + | Prim (loc, D_Pair, l :: rs, annot) -> + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result_syntax.return_unit + else error_unexpected_annot loc annot + in + parse_comb loc l rs + | Prim (loc, D_Pair, l, _) -> + tzfail @@ Invalid_arity (loc, D_Pair, 2, List.length l) + (* Unfold [{x1; ...; xn}] as [Pair x1 x2 ... xn-1 xn] for n >= 2 *) + | Seq (loc, l :: (_ :: _ as rs)) -> parse_comb loc l rs + | Seq (loc, l) -> tzfail @@ Invalid_seq_arity (loc, 2, List.length l) + | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Pair] + + let parse_or parse_l parse_r ctxt ~legacy = + let open Lwt_result_syntax in + function + | Prim (loc, D_Left, [v], annot) -> + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result_syntax.return_unit + else error_unexpected_annot loc annot + in + let+ v, ctxt = parse_l ctxt v in + (L v, ctxt) + | Prim (loc, D_Left, l, _) -> + tzfail @@ Invalid_arity (loc, D_Left, 1, List.length l) + | Prim (loc, D_Right, [v], annot) -> + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result_syntax.return_unit + else error_unexpected_annot loc annot + in + let+ v, ctxt = parse_r ctxt v in + (R v, ctxt) + | Prim (loc, D_Right, l, _) -> + tzfail @@ Invalid_arity (loc, D_Right, 1, List.length l) + | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Left; D_Right] + + let parse_option parse_v ctxt ~legacy = + let open Lwt_result_syntax in + function + | Prim (loc, D_Some, [v], annot) -> + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result_syntax.return_unit + else error_unexpected_annot loc annot + in + let+ v, ctxt = parse_v ctxt v in + (Some v, ctxt) + | Prim (loc, D_Some, l, _) -> + tzfail @@ Invalid_arity (loc, D_Some, 1, List.length l) + | Prim (loc, D_None, [], annot) -> + let*? () = + if legacy (* Legacy check introduced before Ithaca. *) then + Result_syntax.return_unit + else error_unexpected_annot loc annot + in + return (None, ctxt) + | Prim (loc, D_None, l, _) -> + tzfail @@ Invalid_arity (loc, D_None, 0, List.length l) + | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Some; D_None] + (* -- parse data of any type -- *) (* -- GitLab From d6d0b0dad66cf4d14954aac1589b1ea532c278d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 18 Sep 2023 14:41:57 +0200 Subject: [PATCH 09/17] move parse_data to gas monad --- .../lib_protocol/script_ir_translator.ml | 381 ++++++++---------- 1 file changed, 164 insertions(+), 217 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b72a44f0c17e..cf93c0563a86 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4853,11 +4853,11 @@ struct end module Parse_data (M : GAS_MONAD) = struct - let parse_pair (type r) parse_l parse_r ctxt ~legacy + let parse_pair (type r) parse_l parse_r ~legacy (r_comb_witness : (r, unit -> _) comb_witness) expr = - let open Lwt_result_syntax in + let open M in let parse_comb loc l rs = - let* l, ctxt = parse_l ctxt l in + let* l = parse_l l in let*? r = match (rs, r_comb_witness) with | [r], _ -> Ok r @@ -4870,8 +4870,8 @@ module Parse_data (M : GAS_MONAD) = struct Result_syntax.tzfail @@ Invalid_arity (loc, D_Pair, 2, 1 + List.length rs) in - let+ r, ctxt = parse_r ctxt r in - ((l, r), ctxt) + let+ r = parse_r r in + (l, r) in match expr with | Prim (loc, D_Pair, l :: rs, annot) -> @@ -4888,8 +4888,8 @@ module Parse_data (M : GAS_MONAD) = struct | Seq (loc, l) -> tzfail @@ Invalid_seq_arity (loc, 2, List.length l) | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Pair] - let parse_or parse_l parse_r ctxt ~legacy = - let open Lwt_result_syntax in + let parse_or parse_l parse_r ~legacy = + let open M in function | Prim (loc, D_Left, [v], annot) -> let*? () = @@ -4897,8 +4897,8 @@ module Parse_data (M : GAS_MONAD) = struct Result_syntax.return_unit else error_unexpected_annot loc annot in - let+ v, ctxt = parse_l ctxt v in - (L v, ctxt) + let+ v = parse_l v in + L v | Prim (loc, D_Left, l, _) -> tzfail @@ Invalid_arity (loc, D_Left, 1, List.length l) | Prim (loc, D_Right, [v], annot) -> @@ -4907,14 +4907,14 @@ module Parse_data (M : GAS_MONAD) = struct Result_syntax.return_unit else error_unexpected_annot loc annot in - let+ v, ctxt = parse_r ctxt v in - (R v, ctxt) + let+ v = parse_r v in + R v | Prim (loc, D_Right, l, _) -> tzfail @@ Invalid_arity (loc, D_Right, 1, List.length l) | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Left; D_Right] - let parse_option parse_v ctxt ~legacy = - let open Lwt_result_syntax in + let parse_option parse_v ~legacy = + let open M in function | Prim (loc, D_Some, [v], annot) -> let*? () = @@ -4922,8 +4922,8 @@ module Parse_data (M : GAS_MONAD) = struct Result_syntax.return_unit else error_unexpected_annot loc annot in - let+ v, ctxt = parse_v ctxt v in - (Some v, ctxt) + let+ v = parse_v v in + Some v | Prim (loc, D_Some, l, _) -> tzfail @@ Invalid_arity (loc, D_Some, 1, List.length l) | Prim (loc, D_None, [], annot) -> @@ -4932,7 +4932,7 @@ module Parse_data (M : GAS_MONAD) = struct Result_syntax.return_unit else error_unexpected_annot loc annot in - return (None, ctxt) + return None | Prim (loc, D_None, l, _) -> tzfail @@ Invalid_arity (loc, D_None, 0, List.length l) | expr -> tzfail @@ unexpected expr [] Constant_namespace [D_Some; D_None] @@ -4961,19 +4961,17 @@ module Parse_data (M : GAS_MONAD) = struct allow_forged:bool -> (a, ac) ty -> Script.node -> - context -> - (a * context) tzresult Lwt.t = + (a, error trace) M.t = fun ~unparse_code_rec ~parse_packable_data ~elab_conf ~stack_depth ~allow_forged ty - script_data - ctxt -> - let open Lwt_result_syntax in - let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_data_cycle in - let non_terminal_recursion ctxt ty script_data = + script_data -> + let open M in + let*$ () = Typecheck_costs.parse_data_cycle in + let non_terminal_recursion ty script_data = if Compare.Int.(stack_depth > 10_000) then tzfail Typechecking_too_many_recursive_calls else @@ -4985,30 +4983,19 @@ module Parse_data (M : GAS_MONAD) = struct ~allow_forged ty script_data - ctxt in let parse_data_error () = let ty = serialize_ty_for_error ty in Invalid_constant (location script_data, strip_locations script_data, ty) in let fail_parse_data () = tzfail (parse_data_error ()) in - let traced_no_lwt body = record_trace_eval parse_data_error body in - let traced body = trace_eval parse_data_error body in - let traced_from_gas_monad ctxt body = - Lwt.return @@ traced_no_lwt - @@ - let open Result_syntax in - let* res, ctxt = Gas_monad.run ctxt body in - let+ res in - (res, ctxt) - in - let traced_fail err = - Lwt.return @@ traced_no_lwt (Result_syntax.tzfail err) - in - let parse_items ctxt expr key_type value_type items item_wrapper = - let+ _, items, ctxt = - List.fold_left_es - (fun (last_value, map, ctxt) item -> + let traced body = record_trace_eval parse_data_error body in + let traced_from_gas_monad body = traced (from_gas_monad body) in + let traced_fail err = traced (tzfail err) in + let parse_items expr key_type value_type items item_wrapper = + let+ _, items = + list_fold_left + (fun (last_value, map) item -> match item with | Prim (loc, D_Elt, [k; v], annot) -> let*? () = @@ -5018,19 +5005,16 @@ module Parse_data (M : GAS_MONAD) = struct then Result_syntax.return_unit else error_unexpected_annot loc annot in - let* k, ctxt = non_terminal_recursion ctxt key_type k in - let* v, ctxt = non_terminal_recursion ctxt value_type v in - let*? ctxt = - let open Result_syntax in + let* k = non_terminal_recursion key_type k in + let* v = non_terminal_recursion value_type v in + let* () = match last_value with | Some value -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - key_type - value - k) + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.compare + key_type + value + k in let c = Script_comparable.compare_comparable key_type value k @@ -5042,32 +5026,29 @@ module Parse_data (M : GAS_MONAD) = struct else tzfail (Unordered_map_keys (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt + else return_unit + | None -> return_unit in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.map_update k map) + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.map_update k map in - return - (Some k, Script_map.update k (Some (item_wrapper v)) map, ctxt) + return (Some k, Script_map.update k (Some (item_wrapper v)) map) | Prim (loc, D_Elt, l, _) -> tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) | Prim (loc, name, _, _) -> tzfail @@ Invalid_primitive (loc, [D_Elt], name) | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) - (None, Script_map.empty key_type, ctxt) + (None, Script_map.empty key_type) items |> traced in - (items, ctxt) + items in - let parse_big_map_items (type t) ctxt expr (key_type : t comparable_ty) + let parse_big_map_items (type t) expr (key_type : t comparable_ty) value_type items item_wrapper = - let+ _, map, ctxt = - List.fold_left_es - (fun (last_key, {map; size}, ctxt) item -> + let+ _, map = + list_fold_left + (fun (last_key, {map; size}) item -> match item with | Prim (loc, D_Elt, [k; v], annot) -> let*? () = @@ -5077,20 +5058,17 @@ module Parse_data (M : GAS_MONAD) = struct then Result_syntax.return_unit else error_unexpected_annot loc annot in - let* k, ctxt = non_terminal_recursion ctxt key_type k in - let* key_hash, ctxt = hash_comparable_data ctxt key_type k in - let* v, ctxt = non_terminal_recursion ctxt value_type v in - let*? ctxt = - let open Result_syntax in + let* k = non_terminal_recursion key_type k in + let* key_hash = hash_comparable_data key_type k in + let* v = non_terminal_recursion value_type v in + let* () = match last_key with | Some last_key -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - key_type - last_key - k) + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.compare + key_type + last_key + k in let c = Script_comparable.compare_comparable key_type last_key k @@ -5102,14 +5080,12 @@ module Parse_data (M : GAS_MONAD) = struct else tzfail (Unordered_map_keys (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt + else return_unit + | None -> return_unit in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.big_map_update - {map; size}) + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.big_map_update + {map; size} in if Big_map_overlay.mem key_hash map then tzfail (Duplicate_map_keys (loc, strip_locations expr)) @@ -5120,80 +5096,74 @@ module Parse_data (M : GAS_MONAD) = struct map = Big_map_overlay.add key_hash (k, item_wrapper v) map; size = size + 1; - }, - ctxt ) + } ) | Prim (loc, D_Elt, l, _) -> tzfail @@ Invalid_arity (loc, D_Elt, 2, List.length l) | Prim (loc, name, _, _) -> tzfail @@ Invalid_primitive (loc, [D_Elt], name) | Int _ | String _ | Bytes _ | Seq _ -> fail_parse_data ()) - (None, {map = Big_map_overlay.empty; size = 0}, ctxt) + (None, {map = Big_map_overlay.empty; size = 0}) items |> traced in - (map, ctxt) + map in let legacy = elab_conf.legacy in match (ty, script_data) with | Unit_t, expr -> - traced_from_gas_monad ctxt - @@ (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) - | Bool_t, expr -> traced_from_gas_monad ctxt @@ parse_bool ~legacy expr - | String_t, expr -> traced_from_gas_monad ctxt @@ parse_string expr - | Bytes_t, expr -> traced_from_gas_monad ctxt @@ parse_bytes expr - | Int_t, expr -> traced_from_gas_monad ctxt @@ parse_int expr - | Nat_t, expr -> traced_from_gas_monad ctxt @@ parse_nat expr - | Mutez_t, expr -> traced_from_gas_monad ctxt @@ parse_mutez expr - | Timestamp_t, expr -> traced_from_gas_monad ctxt @@ parse_timestamp expr - | Key_t, expr -> traced_from_gas_monad ctxt @@ parse_key expr - | Key_hash_t, expr -> traced_from_gas_monad ctxt @@ parse_key_hash expr - | Signature_t, expr -> traced_from_gas_monad ctxt @@ parse_signature expr + traced_from_gas_monad + (parse_unit ~legacy expr : (a, error trace) Gas_monad.t) + | Bool_t, expr -> traced_from_gas_monad @@ parse_bool ~legacy expr + | String_t, expr -> traced_from_gas_monad @@ parse_string expr + | Bytes_t, expr -> traced_from_gas_monad @@ parse_bytes expr + | Int_t, expr -> traced_from_gas_monad @@ parse_int expr + | Nat_t, expr -> traced_from_gas_monad @@ parse_nat expr + | Mutez_t, expr -> traced_from_gas_monad @@ parse_mutez expr + | Timestamp_t, expr -> traced_from_gas_monad @@ parse_timestamp expr + | Key_t, expr -> traced_from_gas_monad @@ parse_key expr + | Key_hash_t, expr -> traced_from_gas_monad @@ parse_key_hash expr + | Signature_t, expr -> traced_from_gas_monad @@ parse_signature expr | Operation_t, _ -> (* operations cannot appear in parameters or storage, the protocol should never parse the bytes of an operation *) assert false - | Chain_id_t, expr -> traced_from_gas_monad ctxt @@ parse_chain_id expr + | Chain_id_t, expr -> traced_from_gas_monad @@ parse_chain_id expr | Address_t, expr -> - traced_from_gas_monad ctxt + traced_from_gas_monad @@ parse_address ~sc_rollup_enable:elab_conf.sc_rollup_enable ~zk_rollup_enable:elab_conf.zk_rollup_enable expr | Contract_t (arg_ty, _), expr -> traced - (let*? address, ctxt = - Gas_monad.run ctxt + @@ let* address = + from_gas_monad @@ 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 in - let*? address in let loc = location expr in - let+ ctxt, typed_contract = - parse_contract_data - ~stack_depth:(stack_depth + 1) - ctxt - loc - arg_ty - address.destination - ~entrypoint:address.entrypoint - in - (typed_contract, ctxt)) + parse_contract_data + ~stack_depth:(stack_depth + 1) + loc + arg_ty + address.destination + ~entrypoint:address.entrypoint (* Pairs *) | Pair_t (tl, tr, _, _), expr -> let r_witness = comb_witness1 tr in - let parse_l ctxt v = non_terminal_recursion ctxt tl v in - let parse_r ctxt v = non_terminal_recursion ctxt tr v in - traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr + let parse_l v = non_terminal_recursion tl v in + let parse_r v = non_terminal_recursion tr v in + traced @@ parse_pair parse_l parse_r ~legacy r_witness expr (* Ors *) | Or_t (tl, tr, _, _), expr -> - let parse_l ctxt v = non_terminal_recursion ctxt tl v in - let parse_r ctxt v = non_terminal_recursion ctxt tr v in - traced @@ parse_or parse_l parse_r ctxt ~legacy expr + let parse_l v = non_terminal_recursion tl v in + let parse_r v = non_terminal_recursion tr v in + traced @@ parse_or parse_l parse_r ~legacy expr (* Lambdas *) | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> - let* kdescr, ctxt = + let* kdescr = traced @@ parse_kdescr ~unparse_code_rec @@ -5201,14 +5171,12 @@ module Parse_data (M : GAS_MONAD) = struct Tc_context.data ~elab_conf ~stack_depth:(stack_depth + 1) - ctxt ta tr script_instr in (normalized_lam [@ocaml.tailcall]) ~unparse_code_rec - ctxt ~stack_depth kdescr script_instr @@ -5222,7 +5190,6 @@ module Parse_data (M : GAS_MONAD) = struct Tc_context.(add_lambda data) ~elab_conf ~stack_depth:(stack_depth + 1) - ctxt ta tr lambda_rec_ty @@ -5231,16 +5198,16 @@ module Parse_data (M : GAS_MONAD) = struct traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | Option_t (t, _, _), expr -> - let parse_v ctxt v = non_terminal_recursion ctxt t v in - traced @@ parse_option parse_v ctxt ~legacy expr + let parse_v v = non_terminal_recursion t v in + traced @@ parse_option parse_v ~legacy expr (* Lists *) | List_t (t, _ty_name), Seq (_loc, items) -> traced - @@ List.fold_left_es - (fun (rest, ctxt) v -> - let+ v, ctxt = non_terminal_recursion ctxt t v in - (Script_list.cons v rest, ctxt)) - (Script_list.empty, ctxt) + @@ list_fold_left + (fun rest v -> + let+ v = non_terminal_recursion t v in + Script_list.cons v rest) + Script_list.empty (List.rev items) | List_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) @@ -5248,35 +5215,29 @@ module Parse_data (M : GAS_MONAD) = struct | Ticket_t (t, _ty_name), expr -> if allow_forged then let*? ty = opened_ticket_type (location expr) t in - let* ({destination; entrypoint = _}, (contents, amount)), ctxt = - non_terminal_recursion ctxt ty expr + let* {destination; entrypoint = _}, (contents, amount) = + non_terminal_recursion ty expr in match Ticket_amount.of_n amount with | Some amount -> ( match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Contract ticketer -> return {ticketer; contents; amount} | Sc_rollup _ | Zk_rollup _ -> tzfail (Unexpected_ticket_owner destination)) | None -> traced_fail Forbidden_zero_ticket_quantity else traced_fail (Unexpected_forged_value (location expr)) (* Sets *) | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> - let+ _, set, ctxt = + let+ _, set = traced - @@ List.fold_left_es - (fun (last_value, set, ctxt) v -> - let* v, ctxt = non_terminal_recursion ctxt t v in - let*? ctxt = - let open Result_syntax in + @@ list_fold_left + (fun (last_value, set) v -> + let* v = non_terminal_recursion t v in + let* () = match last_value with | Some value -> - let* ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.compare - t - value - v) + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.compare t value v in let c = Script_comparable.compare_comparable t value v in if Compare.Int.(0 <= c) then @@ -5286,44 +5247,37 @@ module Parse_data (M : GAS_MONAD) = struct else tzfail (Unordered_set_values (loc, strip_locations expr)) - else return ctxt - | None -> return ctxt + else return_unit + | None -> return_unit in - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.set_update v set) + let*$ () = + Michelson_v1_gas.Cost_of.Interpreter.set_update v set in - return (Some v, Script_set.update v true set, ctxt)) - (None, Script_set.empty t, ctxt) + return (Some v, Script_set.update v true set)) + (None, Script_set.empty t) vs in - (set, ctxt) + set | Set_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - parse_items ctxt expr tk tv vs (fun x -> x) + parse_items expr tk tv vs (fun x -> x) | Map_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) | Big_map_t (tk, tv, _ty_name), expr -> - let* id_opt, diff, ctxt = + let* id_opt, diff = match expr with | Int (loc, id) -> - return - (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}) | Seq (_, vs) -> - let+ diff, ctxt = - parse_big_map_items ctxt expr tk tv vs (fun x -> Some x) - in - (None, diff, ctxt) + let+ diff = parse_big_map_items expr tk tv vs (fun x -> Some x) in + (None, diff) | Prim (loc, D_Pair, [Int (loc_id, id); Seq (_, vs)], annot) -> let*? () = error_unexpected_annot loc annot in let*? tv_opt = option_t loc tv in - let+ diff, ctxt = - parse_big_map_items ctxt expr tk tv_opt vs (fun x -> x) - in - (Some (id, loc_id), diff, ctxt) + let+ diff = parse_big_map_items expr tk tv_opt vs (fun x -> x) in + (Some (id, loc_id), diff) | Prim (_, D_Pair, [Int _; expr], _) -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) | Prim (_, D_Pair, [expr; _], _) -> @@ -5338,84 +5292,77 @@ module Parse_data (M : GAS_MONAD) = struct Constant_namespace [D_Pair]) in - let+ id, ctxt = + let+ id = match id_opt with - | None -> return (None, ctxt) + | None -> return None | Some (id, loc) -> if allow_forged then let id = Big_map.Id.parse_z id in - let* ctxt, tys_opt = Big_map.exists ctxt id in + let* tys_opt = big_map_exists id in match tys_opt with | None -> traced_fail (Invalid_big_map (loc, id)) | Some (btk, btv) -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* (Ex_comparable_ty btk) = - parse_comparable_ty - ~stack_depth:(stack_depth + 1) - (Micheline.root btk) - in - let* (Ex_ty btv) = - parse_big_map_value_ty - ~stack_depth:(stack_depth + 1) - ~legacy - (Micheline.root btv) - in - let+ Eq = - let error_details = Informative loc in - let* Eq = ty_eq ~error_details tk btk in - ty_eq ~error_details tv btv - in - Some id + from_gas_monad + @@ + let open Gas_monad.Syntax in + let* (Ex_comparable_ty btk) = + parse_comparable_ty + ~stack_depth:(stack_depth + 1) + (Micheline.root btk) + in + let* (Ex_ty btv) = + parse_big_map_value_ty + ~stack_depth:(stack_depth + 1) + ~legacy + (Micheline.root btv) + in + let+ Eq = + let error_details = Informative loc in + let* Eq = ty_eq ~error_details tk btk in + ty_eq ~error_details tv btv in - let*? res in - return (res, ctxt) + Some id else traced_fail (Unexpected_forged_value loc) in - (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) - | Never_t, expr -> traced_from_gas_monad ctxt @@ parse_never expr + Big_map {id; diff; key_type = tk; value_type = tv} + | Never_t, expr -> traced_from_gas_monad @@ parse_never expr (* Bls12_381 types *) - | Bls12_381_g1_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_g1 expr - | Bls12_381_g2_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_g2 expr - | Bls12_381_fr_t, expr -> - traced_from_gas_monad ctxt @@ parse_bls12_381_fr expr + | Bls12_381_g1_t, expr -> traced_from_gas_monad @@ parse_bls12_381_g1 expr + | Bls12_381_g2_t, expr -> traced_from_gas_monad @@ parse_bls12_381_g2 expr + | Bls12_381_fr_t, expr -> traced_from_gas_monad @@ parse_bls12_381_fr expr (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. *) (* Sapling *) | Sapling_transaction_t memo_size, expr -> - traced_from_gas_monad ctxt @@ parse_sapling_transaction ~memo_size expr + traced_from_gas_monad @@ parse_sapling_transaction ~memo_size expr | Sapling_transaction_deprecated_t memo_size, expr -> - traced_from_gas_monad ctxt + traced_from_gas_monad @@ parse_sapling_transaction_deprecated ~memo_size expr | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in - let* state, ctxt = Sapling.state_from_id ctxt id in - let*? () = - traced_no_lwt - @@ memo_size_eq + let* state = sapling_state_from_id id in + traced + @@ let*? () = + memo_size_eq ~error_details:(Informative ()) memo_size state.Sapling.memo_size - in - return (state, ctxt) + in + return state else traced_fail (Unexpected_forged_value loc) | Sapling_state_t memo_size, Seq (_, []) -> - return (Sapling.empty_state ~memo_size (), ctxt) + return (Sapling.empty_state ~memo_size ()) | Sapling_state_t _, expr -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) traced_fail (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) - | Chest_key_t, expr -> traced_from_gas_monad ctxt @@ parse_chest_key expr - | Chest_t, expr -> traced_from_gas_monad ctxt @@ parse_chest expr + | Chest_key_t, expr -> traced_from_gas_monad @@ parse_chest_key expr + | Chest_t, expr -> traced_from_gas_monad @@ parse_chest expr end open Parse_data (LGM) -- GitLab From c19130adb7b5c69f1e3e22131175d9b92d98f89a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 19 Sep 2023 23:46:31 +0200 Subject: [PATCH 10/17] Double instanciation --- .../lib_protocol/script_ir_translator.ml | 50 ++++++++++--------- 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index cf93c0563a86..7f0761635e5a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2169,8 +2169,7 @@ type parse_packable_data = { allow_forged:bool -> ('a, 'ac) ty -> Script.node -> - context -> - ('a * context) tzresult Lwt.t; + ('a, error trace) Gas_monad.t; } let rec parse_view : @@ -2633,16 +2632,17 @@ and parse_instr : @@ parse_packable_ty ~stack_depth:(stack_depth + 1) ~legacy t in let*? (Ex_ty t) = t in - let* v, ctxt = - parse_packable_data.parse_packable_data - ~unparse_code_rec - ~elab_conf - ~stack_depth:(stack_depth + 1) - ~allow_forged:false - t - d - ctxt + let*? v, ctxt = + Gas_monad.run ctxt + @@ parse_packable_data.parse_packable_data + ~unparse_code_rec + ~elab_conf + ~stack_depth:(stack_depth + 1) + ~allow_forged:false + t + d in + let*? v in let push = {apply = (fun k -> IPush (loc, t, v, k))} in typed ctxt loc push (Item_t (t, stack)) | Prim (loc, I_UNIT, [], annot), stack -> @@ -4852,7 +4852,7 @@ struct node end -module Parse_data (M : GAS_MONAD) = struct +module Data_parser (M : GAS_MONAD) = struct let parse_pair (type r) parse_l parse_r ~legacy (r_comb_witness : (r, unit -> _) comb_witness) expr = let open M in @@ -5365,9 +5365,9 @@ module Parse_data (M : GAS_MONAD) = struct | Chest_t, expr -> traced_from_gas_monad @@ parse_chest expr end -open Parse_data (LGM) +module Parse_packable_data = Data_parser (GM) -let rec parse_data : +let rec parse_packable_data : type a ac. unparse_code_rec:Script_ir_unparser.unparse_code_rec -> elab_conf:elab_conf -> @@ -5375,9 +5375,13 @@ let rec parse_data : allow_forged:bool -> (a, ac) ty -> Script.node -> - context -> - (a * context) tzresult Lwt.t = - parse_data_rec ~parse_packable_data:{parse_packable_data = parse_data} + (a, error trace) Gas_monad.t = + Parse_packable_data.parse_data_rec ~parse_packable_data:{parse_packable_data} + +module Parse_data = Data_parser (LGM) + +let parse_data = + Parse_data.parse_data_rec ~parse_packable_data:{parse_packable_data} let view_size view = let open Script_typed_ir_size in @@ -5452,7 +5456,7 @@ let parse_code : (Ill_typed_contract (code, [])) (parse_kdescr ~unparse_code_rec - ~parse_packable_data:{parse_packable_data = parse_data} + ~parse_packable_data:{parse_packable_data} Tc_context.(toplevel ~storage_type ~param_type:arg_type ~entrypoints) ~elab_conf ctxt @@ -5601,7 +5605,7 @@ let typecheck_code : let result = parse_kdescr ~unparse_code_rec - ~parse_packable_data:{parse_packable_data = parse_data} + ~parse_packable_data:{parse_packable_data} (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints) ctxt ~elab_conf @@ -5616,7 +5620,7 @@ let typecheck_code : let views_result = parse_views ~unparse_code_rec - ~parse_packable_data:{parse_packable_data = parse_data} + ~parse_packable_data:{parse_packable_data} ctxt ~elab_conf storage_type @@ -6248,7 +6252,7 @@ let list_of_big_map_ids ids = let parse_view ~elab_conf ctxt ty view = parse_view ~unparse_code_rec - ~parse_packable_data:{parse_packable_data = parse_data} + ~parse_packable_data:{parse_packable_data} ~elab_conf ctxt ty @@ -6257,7 +6261,7 @@ let parse_view ~elab_conf ctxt ty view = let parse_views ~elab_conf ctxt ty views = parse_views ~unparse_code_rec - ~parse_packable_data:{parse_packable_data = parse_data} + ~parse_packable_data:{parse_packable_data} ~elab_conf ctxt ty @@ -6283,7 +6287,7 @@ let parse_instr : fun ~elab_conf tc_context ctxt script_instr stack_ty -> parse_instr ~unparse_code_rec - ~parse_packable_data:{parse_packable_data = parse_data} + ~parse_packable_data:{parse_packable_data} ~elab_conf ~stack_depth:0 tc_context -- GitLab From bd769d8abb020fe85b611c95eb6c8e2a2ac5bd67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 11:48:52 +0200 Subject: [PATCH 11/17] unparse_data, unparse_comparable_data, unparse_code in the gas monad --- .../translator_benchmarks.ml | 16 +- .../lib_protocol/script_ir_translator.ml | 75 ++- .../lib_protocol/script_ir_translator.mli | 8 +- .../lib_protocol/script_ir_unparser.ml | 517 ++++++++---------- .../lib_protocol/script_ir_unparser.mli | 24 +- 5 files changed, 312 insertions(+), 328 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index d15fb2a579d8..00b4fdff3cca 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -320,13 +320,13 @@ module Unparsing_data : Benchmark.S = struct in let closure () = match - Lwt_main.run - (Script_ir_translator.Internal_for_benchmarking.unparse_data + Gas_monad.run_unaccounted + @@ Script_ir_translator.Internal_for_benchmarking.unparse_data ~stack_depth:0 - ctxt + ~elab_conf:(strict ctxt) Script_ir_unparser.Optimized ty - typed) + typed with | Error _ | (exception _) -> bad_data name node michelson_type In_protocol @@ -496,12 +496,12 @@ module Unparsing_code : Benchmark.S = struct in let closure () = let result = - Lwt_main.run - (Script_ir_translator.Internal_for_benchmarking.unparse_code + Gas_monad.run_unaccounted + @@ Script_ir_translator.Internal_for_benchmarking.unparse_code ~stack_depth:0 - ctxt + ~elab_conf:(strict ctxt) Optimized - (Micheline.root node)) + (Micheline.root node) in match Environment.wrap_tzresult result with | Error errs -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 7f0761635e5a..b797aff852d5 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1933,19 +1933,35 @@ let parse_toplevel : Script.expr -> (toplevel, error trace) Gas_monad.t = (* Normalize lambdas during parsing *) -let normalized_lam ~unparse_code_rec ~stack_depth ctxt kdescr code_field = +let normalized_lam ~(unparse_code_rec : Script_ir_unparser.unparse_code_rec) + ~stack_depth ctxt kdescr code_field = let open Lwt_result_syntax in - let+ code_field, ctxt = - unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) Optimized code_field + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? code_field, ctxt = + Gas_monad.run ctxt + @@ unparse_code_rec + ~stack_depth:(stack_depth + 1) + ~elab_conf + Optimized + code_field in - (Lam (kdescr, code_field), ctxt) + let*? code_field in + return (Lam (kdescr, code_field), ctxt) -let normalized_lam_rec ~unparse_code_rec ~stack_depth ctxt kdescr code_field = +let normalized_lam_rec ~(unparse_code_rec : Script_ir_unparser.unparse_code_rec) + ~stack_depth ctxt kdescr code_field = let open Lwt_result_syntax in - let+ code_field, ctxt = - unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) Optimized code_field + let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in + let*? code_field, ctxt = + Gas_monad.run ctxt + @@ unparse_code_rec + ~stack_depth:(stack_depth + 1) + ~elab_conf + Optimized + code_field in - (LamRec (kdescr, code_field), ctxt) + let*? code_field in + return (LamRec (kdescr, code_field), ctxt) (* [parse_contract] is used both to: - parse contract data by [parse_data] ([parse_contract_data]) @@ -3468,8 +3484,9 @@ and parse_instr : let*? lambda_rec_ty = lambda_t loc arg ret in let* code, ctxt = parse_lam_rec - ~unparse_code_rec:(fun ctxt ~stack_depth:_ _unparsing_mode node -> - return (node, ctxt)) + ~unparse_code_rec: + (fun ~stack_depth:_ ~elab_conf:_ _unparsing_mode node -> + Gas_monad.return node) ~parse_packable_data (* No need to normalize the unparsed component to Optimized mode here because the script is already normalized in Optimized mode. *) @@ -5692,14 +5709,14 @@ include Data_unparser (struct let parse_packable_ty = parse_packable_ty - let parse_data = parse_data + let parse_data = parse_packable_data end) -let unparse_code_rec : unparse_code_rec = - let open Lwt_result_syntax in - fun ctxt ~stack_depth mode node -> - let* code, ctxt = unparse_code ctxt ~stack_depth mode node in - return (Micheline.root code, ctxt) +let unparse_code_rec = + let open Gas_monad.Syntax in + fun ~stack_depth ~elab_conf mode node -> + let+ code = unparse_code ~stack_depth ~elab_conf mode node in + Micheline.root code let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage mode ~normalize_types {code; storage} = @@ -5728,16 +5745,20 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt ) = 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:(Script_ir_translator_config.make ~legacy ctxt) + ~elab_conf ctxt ~allow_forged:allow_forged_in_storage storage_type ~storage in - let* code, ctxt = unparse_code ctxt ~stack_depth:0 mode code_field in + let*? code = + 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 in @@ -5776,11 +5797,12 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage let* views, ctxt = Script_map.map_es_in_context (fun ctxt _name {input_ty; output_ty; view_code} -> - let+ view_code, ctxt = - unparse_code ctxt ~stack_depth:0 mode view_code + let*? view_code = + Gas_monad.run_unaccounted + @@ unparse_code ~stack_depth:0 ~elab_conf mode view_code in let view_code = Micheline.root view_code in - ({input_ty; output_ty; view_code}, ctxt)) + return ({input_ty; output_ty; view_code}, ctxt)) ctxt views in @@ -6315,7 +6337,16 @@ let unparse_code ctxt mode code = let* ctxt, code = Global_constants_storage.expand ctxt (strip_locations code) in - unparse_code ~stack_depth:0 ctxt mode (root code) + let*? code, ctxt = + Gas_monad.run ctxt + @@ unparse_code + ~stack_depth:0 + ~elab_conf:Script_ir_translator_config.(make ~legacy:true ctxt) + mode + (root code) + in + let*? code in + return (code, ctxt) let parse_contract_data context loc arg_ty contract ~entrypoint = parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index ba0001b51556..62ecc54b1bae 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -204,19 +204,19 @@ val unparse_code : not carbonated and should not be called directly from the protocol. *) module Internal_for_benchmarking : sig val unparse_data : - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> Script_ir_unparser.unparsing_mode -> ('a, 'ac) ty -> 'a -> - (Script.node * context) tzresult Lwt.t + (Script.node, error trace) Gas_monad.t val unparse_code : - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> Script_ir_unparser.unparsing_mode -> Script.node -> - (Script.node * context) tzresult Lwt.t + (Script.node, error trace) Gas_monad.t end val parse_instr : diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 3f04bd2ccc9f..4fba759a76f8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -331,11 +331,11 @@ type ('ty, 'depth) comb_witness = | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness | Comb_Any : (_, _) comb_witness -let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode +let unparse_pair (type r) ~loc unparse_l unparse_r mode (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) = - let open Lwt_result_syntax in - let* l, ctxt = unparse_l ctxt l in - let+ r, ctxt = unparse_r ctxt r in + let open Gas_monad.Syntax in + let* l = unparse_l l in + let+ r = unparse_r r in (* Fold combs. For combs, three notations are supported: - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)], @@ -347,46 +347,43 @@ let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode - for n=3, [Pair x1 (Pair x2 x3)], - for n>=4, [{x1; x2; ...; xn}]. *) - let res = - match (mode, r_comb_witness, r) with - | Optimized, Comb_Pair _, Micheline.Seq (_, r) -> - (* Optimized case n > 4 *) - Micheline.Seq (loc, l :: r) - | ( Optimized, - Comb_Pair (Comb_Pair _), - Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> - (* Optimized case n = 4 *) - Micheline.Seq (loc, [l; x2; x3; x4]) - | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) -> - (* Readable case n > 2 *) - Prim (loc, D_Pair, l :: xs, []) - | _ -> - (* The remaining cases are: - - Optimized n = 2, - - Optimized n = 3, and - - Readable n = 2, - - Optimized_legacy, any n *) - Prim (loc, D_Pair, [l; r], []) - in - (res, ctxt) - -let unparse_or ~loc unparse_l unparse_r ctxt = - let open Lwt_result_syntax in + match (mode, r_comb_witness, r) with + | Optimized, Comb_Pair _, Micheline.Seq (_, r) -> + (* Optimized case n > 4 *) + Micheline.Seq (loc, l :: r) + | ( Optimized, + Comb_Pair (Comb_Pair _), + Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> + (* Optimized case n = 4 *) + Micheline.Seq (loc, [l; x2; x3; x4]) + | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) -> + (* Readable case n > 2 *) + Prim (loc, D_Pair, l :: xs, []) + | _ -> + (* The remaining cases are: + - Optimized n = 2, + - Optimized n = 3, and + - Readable n = 2, + - Optimized_legacy, any n *) + Prim (loc, D_Pair, [l; r], []) + +let unparse_or ~loc unparse_l unparse_r = + let open Gas_monad.Syntax in function | L l -> - let+ l, ctxt = unparse_l ctxt l in - (Prim (loc, D_Left, [l], []), ctxt) + let+ l = unparse_l l in + Prim (loc, D_Left, [l], []) | R r -> - let+ r, ctxt = unparse_r ctxt r in - (Prim (loc, D_Right, [r], []), ctxt) + let+ r = unparse_r r in + Prim (loc, D_Right, [r], []) -let unparse_option ~loc unparse_v ctxt = - let open Lwt_result_syntax in +let unparse_option ~loc unparse_v = + let open Gas_monad.Syntax in function | Some v -> - let+ v, ctxt = unparse_v ctxt v in - (Prim (loc, D_Some, [v], []), ctxt) - | None -> return (Prim (loc, D_None, [], []), ctxt) + let+ v = unparse_v v in + Prim (loc, D_Some, [v], []) + | None -> return (Prim (loc, D_None, [], [])) (* -- Unparsing data of comparable types -- *) @@ -399,84 +396,62 @@ let comb_witness2 : let rec unparse_comparable_data_rec : type a loc. loc:loc -> - context -> unparsing_mode -> a comparable_ty -> a -> - (loc Script.michelson_node * context) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ~loc ctxt mode ty a -> + (loc Script.michelson_node, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun ~loc mode ty a -> (* No need for stack_depth here. Unlike [unparse_data], [unparse_comparable_data] doesn't call [unparse_code]. The stack depth is bounded by the type depth, currently bounded by 1000 (michelson_maximum_type_size). *) - let*? ctxt = - Gas.consume ctxt Unparse_costs.unparse_data_cycle + let*$ () = + Unparse_costs.unparse_data_cycle (* We could have a smaller cost but let's keep it consistent with [unparse_data] for now. *) in match (ty, a) with - | Unit_t, v -> Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_unit ~loc v - | Int_t, v -> Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_int ~loc v - | Nat_t, v -> Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_nat ~loc v - | String_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_string ~loc s - | Bytes_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_bytes ~loc s - | Bool_t, b -> Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_bool ~loc b - | Timestamp_t, t -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_timestamp ~loc mode t - | Address_t, address -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_address ~loc mode address - | Signature_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_signature ~loc mode s - | Mutez_t, v -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_mutez ~loc v - | Key_t, k -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_key ~loc mode k - | Key_hash_t, k -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_key_hash ~loc mode k - | Chain_id_t, chain_id -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_chain_id ~loc mode chain_id + | Unit_t, v -> unparse_unit ~loc v + | Int_t, v -> unparse_int ~loc v + | Nat_t, v -> unparse_nat ~loc v + | String_t, s -> unparse_string ~loc s + | Bytes_t, s -> unparse_bytes ~loc s + | Bool_t, b -> unparse_bool ~loc b + | Timestamp_t, t -> unparse_timestamp ~loc mode t + | Address_t, address -> unparse_address ~loc mode address + | Signature_t, s -> unparse_signature ~loc mode s + | Mutez_t, v -> unparse_mutez ~loc v + | Key_t, k -> unparse_key ~loc mode k + | Key_hash_t, k -> unparse_key_hash ~loc mode k + | Chain_id_t, chain_id -> unparse_chain_id ~loc mode chain_id | Pair_t (tl, tr, _, YesYes), pair -> let r_witness = comb_witness2 tr in - let unparse_l ctxt v = - unparse_comparable_data_rec ~loc ctxt mode tl v - in - let unparse_r ctxt v = - unparse_comparable_data_rec ~loc ctxt mode tr v - in - unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair + let unparse_l v = unparse_comparable_data_rec ~loc mode tl v in + let unparse_r v = unparse_comparable_data_rec ~loc mode tr v in + unparse_pair ~loc unparse_l unparse_r mode r_witness pair | Or_t (tl, tr, _, YesYes), v -> - let unparse_l ctxt v = - unparse_comparable_data_rec ~loc ctxt mode tl v - in - let unparse_r ctxt v = - unparse_comparable_data_rec ~loc ctxt mode tr v - in - unparse_or ~loc unparse_l unparse_r ctxt v + let unparse_l v = unparse_comparable_data_rec ~loc mode tl v in + let unparse_r v = unparse_comparable_data_rec ~loc mode tr v in + unparse_or ~loc unparse_l unparse_r v | Option_t (t, _, Yes), v -> - let unparse_v ctxt v = unparse_comparable_data_rec ~loc ctxt mode t v in - unparse_option ~loc unparse_v ctxt v + let unparse_v v = unparse_comparable_data_rec ~loc mode t v in + unparse_option ~loc unparse_v v | Never_t, _ -> . -let account_for_future_serialization_cost unparsed_data ctxt = - let open Result_syntax in - let* ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed_data) in +let account_for_future_serialization_cost unparsed_data = + let open Gas_monad.Syntax in + let*$ () = Script.strip_locations_cost unparsed_data in let unparsed_data = Micheline.strip_locations unparsed_data in - let+ ctxt = - Gas.consume ctxt (Script.micheline_serialization_cost unparsed_data) - in - (unparsed_data, ctxt) + let+$ () = Script.micheline_serialization_cost unparsed_data in + unparsed_data type unparse_code_rec = - t -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> Script.node -> - ((canonical_location, prim) node * t, error trace) result Lwt.t + (Script.node, error trace) Gas_monad.t module type MICHELSON_PARSER = sig val opened_ticket_type : @@ -498,8 +473,7 @@ module type MICHELSON_PARSER = sig allow_forged:bool -> ('a, 'ac) ty -> Script.node -> - context -> - ('a * context) tzresult Lwt.t + ('a, error trace) Gas_monad.t end module Data_unparser (P : MICHELSON_PARSER) = struct @@ -508,122 +482,99 @@ module Data_unparser (P : MICHELSON_PARSER) = struct (* -- Unparsing data of any type -- *) let rec unparse_data_rec : type a ac. - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> (a, ac) ty -> a -> - (Script.node * context) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ctxt ~stack_depth mode ty a -> - let*? ctxt = Gas.consume ctxt Unparse_costs.unparse_data_cycle in - let non_terminal_recursion ctxt mode ty a = + (Script.node, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun ~stack_depth ~elab_conf mode ty a -> + let*$ () = Unparse_costs.unparse_data_cycle in + let non_terminal_recursion mode ty a = if Compare.Int.(stack_depth > 10_000) then tzfail Script_tc_errors.Unparsing_too_many_recursive_calls - else unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode ty a + else + unparse_data_rec ~stack_depth:(stack_depth + 1) ~elab_conf mode ty a in let loc = Micheline.dummy_location in match (ty, a) with - | Unit_t, v -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_unit ~loc v - | Int_t, v -> Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_int ~loc v - | Nat_t, v -> Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_nat ~loc v - | String_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_string ~loc s - | Bytes_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_bytes ~loc s - | Bool_t, b -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_bool ~loc b - | Timestamp_t, t -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_timestamp ~loc mode t - | Address_t, address -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_address ~loc mode address - | Contract_t _, contract -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_contract ~loc mode contract - | Signature_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_signature ~loc mode s - | Mutez_t, v -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_mutez ~loc v - | Key_t, k -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_key ~loc mode k - | Key_hash_t, k -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_key_hash ~loc mode k - | Operation_t, operation -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_operation ~loc operation - | Chain_id_t, chain_id -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_chain_id ~loc mode chain_id - | Bls12_381_g1_t, x -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_bls12_381_g1 ~loc x - | Bls12_381_g2_t, x -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_bls12_381_g2 ~loc x - | Bls12_381_fr_t, x -> - Lwt.return @@ Gas_monad.run_pure ctxt @@ unparse_bls12_381_fr ~loc x + | Unit_t, v -> unparse_unit ~loc v + | Int_t, v -> unparse_int ~loc v + | Nat_t, v -> unparse_nat ~loc v + | String_t, s -> unparse_string ~loc s + | Bytes_t, s -> unparse_bytes ~loc s + | Bool_t, b -> unparse_bool ~loc b + | Timestamp_t, t -> unparse_timestamp ~loc mode t + | Address_t, address -> unparse_address ~loc mode address + | Contract_t _, contract -> unparse_contract ~loc mode contract + | Signature_t, s -> unparse_signature ~loc mode s + | Mutez_t, v -> unparse_mutez ~loc v + | Key_t, k -> unparse_key ~loc mode k + | Key_hash_t, k -> unparse_key_hash ~loc mode k + | Operation_t, operation -> unparse_operation ~loc operation + | Chain_id_t, chain_id -> unparse_chain_id ~loc mode chain_id + | Bls12_381_g1_t, x -> unparse_bls12_381_g1 ~loc x + | Bls12_381_g2_t, x -> unparse_bls12_381_g2 ~loc x + | Bls12_381_fr_t, x -> unparse_bls12_381_fr ~loc x | Pair_t (tl, tr, _, _), pair -> let r_witness = comb_witness2 tr in - let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in - let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair + let unparse_l v = non_terminal_recursion mode tl v in + let unparse_r v = non_terminal_recursion mode tr v in + unparse_pair ~loc unparse_l unparse_r mode r_witness pair | Or_t (tl, tr, _, _), v -> - let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in - let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_or ~loc unparse_l unparse_r ctxt v + let unparse_l v = non_terminal_recursion mode tl v in + let unparse_r v = non_terminal_recursion mode tr v in + unparse_or ~loc unparse_l unparse_r v | Option_t (t, _, _), v -> - let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in - unparse_option ~loc unparse_v ctxt v + let unparse_v v = non_terminal_recursion mode t v in + unparse_option ~loc unparse_v v | List_t (t, _), items -> - let+ items, ctxt = - List.fold_left_es - (fun (l, ctxt) element -> - let+ unparsed, ctxt = - non_terminal_recursion ctxt mode t element - in - (unparsed :: l, ctxt)) - ([], ctxt) + let+ items = + Gas_monad.list_fold_left + (fun l element -> + let+ unparsed = non_terminal_recursion mode t element in + unparsed :: l) + [] items.elements in - (Micheline.Seq (loc, List.rev items), ctxt) + Micheline.Seq (loc, List.rev items) | Ticket_t (t, _), {ticketer; contents; amount} -> (* ideally we would like to allow a little overhead here because it is only used for unparsing *) let*? t = P.opened_ticket_type loc t in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in (unparse_data_rec [@tailcall]) - ctxt ~stack_depth + ~elab_conf mode t (addr, (contents, (amount :> Script_int.n Script_int.num))) | Set_t (t, _), set -> - let+ items, ctxt = - List.fold_left_es - (fun (l, ctxt) item -> - let+ item, ctxt = - unparse_comparable_data_rec ~loc ctxt mode t item - in - (item :: l, ctxt)) - ([], ctxt) + let+ items = + Gas_monad.list_fold_left + (fun l item -> + let+ item = unparse_comparable_data_rec ~loc mode t item in + item :: l) + [] (Script_set.fold (fun e acc -> e :: acc) set []) in - (Micheline.Seq (loc, items), ctxt) + Micheline.Seq (loc, items) | Map_t (kt, vt, _), map -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in - let+ items, ctxt = + let+ items = unparse_items_rec - ctxt ~stack_depth:(stack_depth + 1) + ~elab_conf mode kt vt items in - (Micheline.Seq (loc, items), ctxt) + Micheline.Seq (loc, items) | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} when Compare.Int.( = ) size 0 -> - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id)) | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> let items = Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] @@ -641,21 +592,20 @@ module Data_unparser (P : MICHELSON_PARSER) = struct (* this can't fail if the original type is well-formed because [option vt] is always strictly smaller than [big_map kt vt] *) let*? vt = option_t loc vt in - let+ items, ctxt = + let+ items = unparse_items_rec - ctxt ~stack_depth:(stack_depth + 1) + ~elab_conf mode kt vt items in - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) + Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ) | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> let items = Big_map_overlay.fold @@ -670,127 +620,120 @@ module Data_unparser (P : MICHELSON_PARSER) = struct (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) items in - let+ items, ctxt = + let+ items = unparse_items_rec - ctxt ~stack_depth:(stack_depth + 1) + ~elab_conf mode kt vt items in - (Micheline.Seq (loc, items), ctxt) + Micheline.Seq (loc, items) | Lambda_t _, Lam (_, original_code) -> unparse_code_rec - ctxt ~stack_depth:(stack_depth + 1) + ~elab_conf mode original_code | Lambda_t _, LamRec (_, original_code) -> - let+ body, ctxt = + let+ body = unparse_code_rec - ctxt ~stack_depth:(stack_depth + 1) + ~elab_conf mode original_code in - (Micheline.Prim (loc, D_Lambda_rec, [body], []), ctxt) + Micheline.Prim (loc, D_Lambda_rec, [body], []) | Never_t, _ -> . | Sapling_transaction_t _, s -> - let*? ctxt = Gas.consume ctxt (Unparse_costs.sapling_transaction s) in + let*$ () = Unparse_costs.sapling_transaction s in let bytes = Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in - return (Bytes (loc, bytes), ctxt) + return (Bytes (loc, bytes)) | Sapling_transaction_deprecated_t _, s -> - let*? ctxt = - Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) - in + let*$ () = Unparse_costs.sapling_transaction_deprecated s in let bytes = Data_encoding.Binary.to_bytes_exn Sapling.Legacy.transaction_encoding s in - return (Bytes (loc, bytes), ctxt) + return (Bytes (loc, bytes)) | Sapling_state_t _, {id; diff; _} -> - let*? ctxt = Gas.consume ctxt (Unparse_costs.sapling_diff diff) in + let*$ () = Unparse_costs.sapling_diff diff in return - ( (match diff with - | {commitments_and_ciphertexts = []; nullifiers = []} -> ( - match id with - | None -> Micheline.Seq (loc, []) - | Some id -> - let id = Sapling.Id.unparse_to_z id in - Micheline.Int (loc, id)) - | diff -> ( - let diff_bytes = - Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff - in - let unparsed_diff = Bytes (loc, diff_bytes) in - match id with - | None -> unparsed_diff - | Some id -> - let id = Sapling.Id.unparse_to_z id in - Micheline.Prim - (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), - ctxt ) + (match diff with + | {commitments_and_ciphertexts = []; nullifiers = []} -> ( + match id with + | None -> Micheline.Seq (loc, []) + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Int (loc, id)) + | diff -> ( + let diff_bytes = + Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff + in + let unparsed_diff = Bytes (loc, diff_bytes) in + match id with + | None -> unparsed_diff + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Prim + (loc, D_Pair, [Int (loc, id); unparsed_diff], []))) | Chest_key_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_with_data_encoding - ~loc - s - Unparse_costs.chest_key - Script_timelock.chest_key_encoding + unparse_with_data_encoding + ~loc + s + Unparse_costs.chest_key + Script_timelock.chest_key_encoding | Chest_t, s -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_with_data_encoding - ~loc - s - (Unparse_costs.chest - ~plaintext_size:(Script_timelock.get_plaintext_size s)) - Script_timelock.chest_encoding + unparse_with_data_encoding + ~loc + s + (Unparse_costs.chest + ~plaintext_size:(Script_timelock.get_plaintext_size s)) + Script_timelock.chest_encoding and unparse_items_rec : type k v vc. - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> k comparable_ty -> (v, vc) ty -> (k * v) list -> - (Script.node list * context) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ctxt ~stack_depth mode kt vt items -> - List.fold_left_es - (fun (l, ctxt) (k, v) -> + (Script.node list, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun ~stack_depth ~elab_conf mode kt vt items -> + Gas_monad.list_fold_left + (fun l (k, v) -> let loc = Micheline.dummy_location in - let* key, ctxt = unparse_comparable_data_rec ~loc ctxt mode kt k in - let+ value, ctxt = - unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode vt v + let* key = unparse_comparable_data_rec ~loc mode kt k in + let+ value = + unparse_data_rec ~stack_depth:(stack_depth + 1) ~elab_conf mode vt v in - (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) - ([], ctxt) + Prim (loc, D_Elt, [key; value], []) :: l) + [] items - 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 ctxt in - let*? ctxt = Gas.consume ctxt Unparse_costs.unparse_instr_cycle in - let non_terminal_recursion ctxt mode code = + and unparse_code_rec ~stack_depth ~elab_conf mode code : + (Script.node, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + let*$ () = Unparse_costs.unparse_instr_cycle in + let non_terminal_recursion mode code = if Compare.Int.(stack_depth > 10_000) then tzfail Unparsing_too_many_recursive_calls - else unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode code + else unparse_code_rec ~stack_depth:(stack_depth + 1) ~elab_conf mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ P.parse_packable_ty - ~stack_depth:(stack_depth + 1) - ~legacy:elab_conf.legacy - ty + let* (Ex_ty t) = + P.parse_packable_ty + ~stack_depth:(stack_depth + 1) + ~legacy:elab_conf.legacy + ty in - let*? (Ex_ty t) = res in let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -798,7 +741,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - let* data, ctxt = + let* data = P.parse_data ~unparse_code_rec ~elab_conf @@ -806,55 +749,64 @@ module Data_unparser (P : MICHELSON_PARSER) = struct ~allow_forged t data - ctxt in - let* data, ctxt = - unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode t data + let* data = + unparse_data_rec ~stack_depth:(stack_depth + 1) ~elab_conf mode t data in - return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) + return (Prim (loc, I_PUSH, [ty; data], annot)) | Seq (loc, items) -> - let* items, ctxt = - List.fold_left_es - (fun (l, ctxt) item -> - let+ item, ctxt = non_terminal_recursion ctxt mode item in - (item :: l, ctxt)) - ([], ctxt) + let* items = + Gas_monad.list_fold_left + (fun l item -> + let+ item = non_terminal_recursion mode item in + item :: l) + [] items in - return (Micheline.Seq (loc, List.rev items), ctxt) + return (Micheline.Seq (loc, List.rev items)) | Prim (loc, prim, items, annot) -> - let* items, ctxt = - List.fold_left_es - (fun (l, ctxt) item -> - let+ item, ctxt = non_terminal_recursion ctxt mode item in - (item :: l, ctxt)) - ([], ctxt) + let* items = + Gas_monad.list_fold_left + (fun l item -> + let+ item = non_terminal_recursion mode item in + item :: l) + [] items in - return (Prim (loc, prim, List.rev items, annot), ctxt) - | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) + 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* unparsed_data, ctxt = unparse_data_rec ctxt ~stack_depth mode ty v in - Lwt.return (account_for_future_serialization_cost unparsed_data ctxt) + 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_code ctxt ~stack_depth mode v = - let open Lwt_result_syntax in - let* unparsed_data, ctxt = unparse_code_rec ctxt ~stack_depth mode v in - Lwt.return (account_for_future_serialization_cost unparsed_data ctxt) + let unparse_code ~stack_depth ~elab_conf mode v = + let open Gas_monad.Syntax in + 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* unparsed_datas, ctxt = - unparse_items_rec ctxt ~stack_depth mode ty vty vs + 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 = - account_for_future_serialization_cost unparsed_data ctxt + Gas_monad.run_pure ctxt + @@ account_for_future_serialization_cost unparsed_data in (unparsed_data :: acc, ctxt)) ([], ctxt) @@ -871,7 +823,10 @@ end let unparse_comparable_data ctxt mode ty v = let open Lwt_result_syntax in - let* unparsed_data, ctxt = - unparse_comparable_data_rec ctxt ~loc:() mode ty v + let*? unparsed_data, ctxt = + Gas_monad.run ctxt @@ unparse_comparable_data_rec ~loc:() mode ty v in - Lwt.return (account_for_future_serialization_cost unparsed_data ctxt) + let*? unparsed_data in + Lwt.return + (Gas_monad.run_pure ctxt + @@ account_for_future_serialization_cost unparsed_data) diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 44d199e8c535..1490582750ab 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -149,11 +149,11 @@ val unparse_contract : several functions of [Script_ir_translator]. To avoid repeating the signature of this function we define a type alias for it. *) type unparse_code_rec = - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> Script.node -> - (Script.node * context) tzresult Lwt.t + (Script.node, error trace) Gas_monad.t (** [MICHELSON_PARSER] signature describes a set of dependencies required to unparse arbitrary values in the IR. Because some of those values contain @@ -181,8 +181,7 @@ module type MICHELSON_PARSER = sig allow_forged:bool -> ('a, 'ac) ty -> Script.node -> - context -> - ('a * context) tzresult Lwt.t + ('a, error trace) Gas_monad.t end module Data_unparser : functor (P : MICHELSON_PARSER) -> sig @@ -210,34 +209,33 @@ module Data_unparser : functor (P : MICHELSON_PARSER) -> sig ('k * 'v) list -> (Script.expr list * context) tzresult Lwt.t - (** [unparse_code ctxt ~stack_depth unparsing_mode code] returns [code] + (** [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. The gas is being consumed from - [ctxt]. *) + only forgeable values are being pushed. Gas is being consumed. *) val unparse_code : - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> Script.node -> - (Script.expr * context, error trace) result Lwt.t + (Script.expr, error trace) Gas_monad.t (** For benchmarking purpose, we also export versions of the unparsing functions which don't call location stripping. These functions are not carbonated and should not be called directly from the protocol. *) module Internal_for_benchmarking : sig val unparse_data : - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> ('a, 'ac) ty -> 'a -> - (Script.node * context) tzresult Lwt.t + (Script.node, error trace) Gas_monad.t val unparse_code : - context -> stack_depth:int -> + elab_conf:Script_ir_translator_config.elab_config -> unparsing_mode -> Script.node -> - (Script.node * context) tzresult Lwt.t + (Script.node, error trace) Gas_monad.t end end -- GitLab From c38e654696d4ea96b57072243021bc471e955d98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 12:16:48 +0200 Subject: [PATCH 12/17] normalize_lam_rec in gas monad --- .../lib_protocol/script_ir_translator.ml | 55 +++++++++++-------- 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b797aff852d5..0107a63c8491 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1949,19 +1949,16 @@ let normalized_lam ~(unparse_code_rec : Script_ir_unparser.unparse_code_rec) return (Lam (kdescr, code_field), ctxt) let normalized_lam_rec ~(unparse_code_rec : Script_ir_unparser.unparse_code_rec) - ~stack_depth ctxt kdescr code_field = - let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in - let*? code_field, ctxt = - Gas_monad.run ctxt - @@ unparse_code_rec - ~stack_depth:(stack_depth + 1) - ~elab_conf - Optimized - code_field + ~elab_conf ~stack_depth kdescr code_field = + let open Gas_monad.Syntax in + let+ code_field = + unparse_code_rec + ~stack_depth:(stack_depth + 1) + ~elab_conf + Optimized + code_field in - let*? code_field in - return (LamRec (kdescr, code_field), ctxt) + LamRec (kdescr, code_field) (* [parse_contract] is used both to: - parse contract data by [parse_data] ([parse_contract_data]) @@ -2416,23 +2413,33 @@ and parse_lam_rec : kdescr), ctxt ) in - (normalized_lam_rec [@ocaml.tailcall]) - ~unparse_code_rec - ~stack_depth - ctxt - closed_descr - script_instr + let*? res, ctxt = + Gas_monad.run ctxt + @@ normalized_lam_rec + ~unparse_code_rec + ~stack_depth:(stack_depth + 1) + ~elab_conf + closed_descr + script_instr + in + let*? res in + return (res, ctxt) | Typed {loc; aft = stack_ty; _}, _ctxt -> let ret = serialize_ty_for_error ret 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]) - ~unparse_code_rec - ~stack_depth - ctxt - (close_descr (descr (Item_t (ret, Bot_t)))) - script_instr + let*? res, ctxt = + Gas_monad.run ctxt + @@ normalized_lam_rec + ~unparse_code_rec + ~stack_depth + ~elab_conf + (close_descr (descr (Item_t (ret, Bot_t)))) + script_instr + in + let*? res in + return (res, ctxt) and parse_instr : type a s. -- GitLab From db4b5b3ef737510d917eac3a4005e6aca53a1044 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 12:17:49 +0200 Subject: [PATCH 13/17] parse_{view,views,kdescr,instr} in gas monad --- .../lib_protocol/script_ir_translator.ml | 1391 +++++++---------- 1 file changed, 560 insertions(+), 831 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 0107a63c8491..6e05ee1b88c8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2190,61 +2190,51 @@ let rec parse_view : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> - context -> (storage, storagec) ty -> view -> - (storage typed_view * context) tzresult Lwt.t = - let open Lwt_result_syntax in + (storage typed_view, error trace) Gas_monad.t = + let open Gas_monad.Syntax in fun ~unparse_code_rec ~parse_packable_data ~elab_conf - ctxt storage_type {input_ty; output_ty; view_code} -> let legacy = elab_conf.legacy in let input_ty_loc = location input_ty in let output_ty_loc = location output_ty in - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let error_details = Informative () in - let* input_ty = - Gas_monad.record_trace_eval ~error_details (fun () -> - Ill_formed_type - (Some "arg of view", strip_locations input_ty, input_ty_loc)) - @@ parse_view_input_ty ~stack_depth:0 ~legacy input_ty - in - let+ output_ty = - Gas_monad.record_trace_eval ~error_details (fun () -> - Ill_formed_type - (Some "return of view", strip_locations output_ty, output_ty_loc)) - @@ parse_view_output_ty ~stack_depth:0 ~legacy output_ty - in - (input_ty, output_ty) + let* (Ex_ty input_ty) = + Gas_monad.record_trace_eval + ~error_details:(Informative ()) + (fun () -> + Ill_formed_type + (Some "arg of view", strip_locations input_ty, input_ty_loc)) + (parse_view_input_ty ~stack_depth:0 ~legacy input_ty) + in + let* (Ex_ty output_ty) = + Gas_monad.record_trace_eval + ~error_details:(Informative ()) + (fun () -> + Ill_formed_type + (Some "return of view", strip_locations output_ty, output_ty_loc)) + (parse_view_output_ty ~stack_depth:0 ~legacy output_ty) in - let*? Ex_ty input_ty, Ex_ty output_ty = res in let*? (Ty_ex_c pair_ty) = pair_t input_ty_loc input_ty storage_type in - let* judgement, ctxt = + let* judgement = parse_instr ~unparse_code_rec ~parse_packable_data ~elab_conf ~stack_depth:0 Tc_context.view - ctxt view_code (Item_t (pair_ty, Bot_t)) in - Lwt.return - @@ match judgement with | Failed {descr} -> let {kinstr; _} = close_descr (descr (Item_t (output_ty, Bot_t))) in - Ok - ( Typed_view - {input_ty; output_ty; kinstr; original_code_expr = view_code}, - ctxt ) + return + (Typed_view + {input_ty; output_ty; kinstr; original_code_expr = view_code}) | Typed ({loc; aft; _} as descr) -> ( let ill_type_view stack_ty loc = let actual = serialize_stack_for_error stack_ty in @@ -2252,22 +2242,17 @@ let rec parse_view : let expected = serialize_stack_for_error expected_stack in Ill_typed_view {loc; actual; expected} in - let open Result_syntax in match aft with | Item_t (ty, Bot_t) -> let error_details = Informative loc in - let* eq, ctxt = - Gas_monad.run ctxt - @@ Gas_monad.record_trace_eval ~error_details (fun loc -> - ill_type_view aft loc) + let+ Eq = + Gas_monad.record_trace_eval ~error_details (fun loc -> + ill_type_view aft loc) @@ ty_eq ~error_details ty output_ty in - let* Eq = eq in let {kinstr; _} = close_descr descr in - Ok - ( Typed_view - {input_ty; output_ty; kinstr; original_code_expr = view_code}, - ctxt ) + Typed_view + {input_ty; output_ty; kinstr; original_code_expr = view_code} | _ -> tzfail (ill_type_view aft loc)) and parse_views : @@ -2275,27 +2260,21 @@ and parse_views : unparse_code_rec:Script_ir_unparser.unparse_code_rec -> parse_packable_data:parse_packable_data -> elab_conf:elab_conf -> - context -> (storage, storagec) ty -> view_map -> - (storage typed_view_map * context) tzresult Lwt.t = - let open Lwt_result_syntax in - fun ~unparse_code_rec ~parse_packable_data ~elab_conf ctxt storage_type views -> - let aux ctxt name cur_view = - let*? ctxt = - Gas.consume - ctxt - (Michelson_v1_gas.Cost_of.Interpreter.view_update name views) - in + (storage typed_view_map, error trace) Gas_monad.t = + let open Gas_monad.Syntax in + fun ~unparse_code_rec ~parse_packable_data ~elab_conf storage_type views -> + let aux name cur_view = + let*$ () = Michelson_v1_gas.Cost_of.Interpreter.view_update name views in parse_view ~unparse_code_rec ~parse_packable_data ~elab_conf - ctxt storage_type cur_view in - Script_map.map_es_in_context aux ctxt views + Script_map.map_in_gas_monad aux views and parse_kdescr : type arg argc ret retc. @@ -2304,18 +2283,16 @@ and parse_kdescr : elab_conf:elab_conf -> stack_depth:int -> tc_context -> - context -> (arg, argc) ty -> (ret, retc) ty -> Script.node -> - ((arg, end_of_stack, ret, end_of_stack) kdescr * context) tzresult Lwt.t = - let open Lwt_result_syntax in + ((arg, end_of_stack, ret, end_of_stack) kdescr, error trace) Gas_monad.t = + let open Gas_monad.Syntax in fun ~unparse_code_rec ~parse_packable_data ~elab_conf ~stack_depth tc_context - ctxt arg ret script_instr -> @@ -2325,35 +2302,30 @@ and parse_kdescr : ~parse_packable_data ~elab_conf tc_context - ctxt ~stack_depth:(stack_depth + 1) script_instr (Item_t (arg, Bot_t)) in match result with - | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt -> + | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr) -> let error_details = Informative loc in - let*? eq, ctxt = - 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 stack_ty in - Bad_return (loc, stack_ty, ret)) + let* Eq = + Gas_monad.record_trace_eval ~error_details (fun loc -> + let ret = serialize_ty_for_error ret in + let stack_ty = serialize_stack_for_error stack_ty in + Bad_return (loc, stack_ty, ret)) @@ ty_eq ~error_details ty ret in - let*? Eq = eq in return - ( (close_descr descr : (arg, end_of_stack, ret, end_of_stack) kdescr), - ctxt ) - | Typed {loc; aft = stack_ty; _}, _ctxt -> + (close_descr descr : (arg, end_of_stack, ret, end_of_stack) kdescr) + | Typed {loc; aft = stack_ty; _} -> let ret = serialize_ty_for_error ret in let stack_ty = serialize_stack_for_error stack_ty in tzfail @@ Bad_return (loc, stack_ty, ret) - | Failed {descr}, ctxt -> + | Failed {descr} -> return - ( (close_descr (descr (Item_t (ret, Bot_t))) - : (arg, end_of_stack, ret, end_of_stack) kdescr), - ctxt ) + (close_descr (descr (Item_t (ret, Bot_t))) + : (arg, end_of_stack, ret, end_of_stack) kdescr) and parse_lam_rec : type arg argc ret retc. @@ -2362,84 +2334,63 @@ and parse_lam_rec : elab_conf:elab_conf -> stack_depth:int -> tc_context -> - context -> (arg, argc) ty -> (ret, retc) ty -> ((arg, ret) lambda, _) ty -> Script.node -> - ((arg, ret) lambda * context) tzresult Lwt.t = + ((arg, ret) lambda, error trace) Gas_monad.t = fun ~unparse_code_rec ~parse_packable_data ~elab_conf ~stack_depth tc_context - ctxt arg ret lambda_rec_ty script_instr -> - let open Lwt_result_syntax in + let open Gas_monad.Syntax in let* result = parse_instr ~unparse_code_rec ~parse_packable_data ~elab_conf tc_context - ctxt ~stack_depth:(stack_depth + 1) script_instr (Item_t (arg, Item_t (lambda_rec_ty, Bot_t))) in match result with - | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt -> - let*? closed_descr, ctxt = - let open Result_syntax in + | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr) -> + let* closed_descr = let error_details = Informative loc in - let* eq, ctxt = - 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 stack_ty in - Bad_return (loc, stack_ty, ret)) + let+ Eq = + Gas_monad.record_trace_eval ~error_details (fun loc -> + let ret = serialize_ty_for_error ret in + let stack_ty = serialize_stack_for_error stack_ty in + Bad_return (loc, stack_ty, ret)) @@ ty_eq ~error_details ty ret in - let* Eq = eq in - Ok - ( (close_descr descr - : ( arg, - (arg, ret) lambda * end_of_stack, - ret, - end_of_stack ) - kdescr), - ctxt ) - in - let*? res, ctxt = - Gas_monad.run ctxt - @@ normalized_lam_rec - ~unparse_code_rec - ~stack_depth:(stack_depth + 1) - ~elab_conf - closed_descr - script_instr + + (close_descr descr + : (arg, (arg, ret) lambda * end_of_stack, ret, end_of_stack) kdescr) in - let*? res in - return (res, ctxt) - | Typed {loc; aft = stack_ty; _}, _ctxt -> + (normalized_lam_rec [@ocaml.tailcall]) + ~unparse_code_rec + ~stack_depth + ~elab_conf + closed_descr + script_instr + | Typed {loc; aft = stack_ty; _} -> let ret = serialize_ty_for_error ret in let stack_ty = serialize_stack_for_error stack_ty in tzfail @@ Bad_return (loc, stack_ty, ret) - | Failed {descr}, ctxt -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ normalized_lam_rec - ~unparse_code_rec - ~stack_depth - ~elab_conf - (close_descr (descr (Item_t (ret, Bot_t)))) - script_instr - in - let*? res in - return (res, ctxt) + | Failed {descr} -> + (normalized_lam_rec [@ocaml.tailcall]) + ~unparse_code_rec + ~stack_depth + ~elab_conf + (close_descr (descr (Item_t (ret, Bot_t)))) + script_instr and parse_instr : type a s. @@ -2448,35 +2399,32 @@ and parse_instr : elab_conf:elab_conf -> stack_depth:int -> tc_context -> - context -> Script.node -> (a, s) stack_ty -> - ((a, s) judgement * context) tzresult Lwt.t = + ((a, s) judgement, error trace) Gas_monad.t = fun ~unparse_code_rec ~parse_packable_data ~elab_conf ~stack_depth tc_context - ctxt script_instr stack_ty -> - let open Lwt_result_syntax in + let open Gas_monad.Syntax in let for_logging_only x = if elab_conf.keep_extra_types_for_interpreter_logging then Some x else None in - let check_item_ty (type a ac b bc) ctxt (exp : (a, ac) ty) (got : (b, bc) ty) - loc name n m : ((a, b) eq * context) tzresult = - let open Result_syntax in + let record_trace_eval f m = + Gas_monad.record_trace_eval ~error_details:(Informative ()) f m + in + let check_item_ty (type a ac b bc) (exp : (a, ac) ty) (got : (b, bc) ty) loc + name n m : ((a, b) eq, error trace) Gas_monad.t = record_trace_eval (fun () -> let stack_ty = serialize_stack_for_error stack_ty in Bad_stack (loc, name, m, stack_ty)) - @@ record_trace - (Bad_stack_item n) - (let* eq, ctxt = - Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) exp got - in - let* Eq = eq in - Ok ((Eq : (a, b) eq), ctxt)) + @@ record_trace_eval + (fun () -> Bad_stack_item n) + (let+ Eq = ty_eq ~error_details:(Informative loc) exp got in + (Eq : (a, b) eq)) in let log_stack loc stack_ty aft = match (elab_conf.type_logger, script_instr) with @@ -2488,16 +2436,13 @@ and parse_instr : let stack_ty_after = unparse_stack_uncarbonated aft in log loc ~stack_ty_before ~stack_ty_after in - let typed_no_lwt ctxt loc instr aft = + let typed loc instr aft = log_stack loc stack_ty aft ; let j = Typed {loc; instr; bef = stack_ty; aft} in - Ok (j, ctxt) - in - let typed ctxt loc instr aft = - Lwt.return @@ typed_no_lwt ctxt loc instr aft + return j in - let*? ctxt = Gas.consume ctxt Typecheck_costs.parse_instr_cycle in - let non_terminal_recursion tc_context ctxt script_instr stack_ty = + let*$ () = Typecheck_costs.parse_instr_cycle in + let non_terminal_recursion tc_context script_instr stack_ty = if Compare.Int.(stack_depth > 10000) then tzfail Typechecking_too_many_recursive_calls else @@ -2506,7 +2451,6 @@ and parse_instr : ~parse_packable_data ~elab_conf tc_context - ctxt ~stack_depth:(stack_depth + 1) script_instr stack_ty @@ -2521,11 +2465,11 @@ and parse_instr : (* stack ops *) | Prim (loc, I_DROP, [], annot), Item_t (_, rest) -> (let*? () = error_unexpected_annot loc annot in - typed ctxt loc {apply = (fun k -> IDrop (loc, k))} rest - : ((a, s) judgement * context) tzresult Lwt.t) + typed loc {apply = (fun k -> IDrop (loc, k))} rest + : ((a, s) judgement, error trace) Gas_monad.t) | Prim (loc, I_DROP, [n], result_annot), whole_stack -> let*? whole_n = parse_uint10 n in - let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in + let*$ () = Typecheck_costs.proof_argument whole_n in let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a, s) dropn_proof_argument tzresult = @@ -2547,23 +2491,22 @@ and parse_instr : make_proof_argument whole_n whole_stack in let kdropn k = IDropn (loc, whole_n, n', k) in - typed ctxt loc {apply = kdropn} stack_after_drops + typed loc {apply = kdropn} stack_after_drops | Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _ -> (* Technically, the arities 0 and 1 are allowed but the error only mentions 1. However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *) 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*? res, ctxt = Gas_monad.run ctxt @@ check_dupable_ty loc v in - let*? () = + let* () = record_trace_eval (fun () -> let t = serialize_ty_for_error v in Non_dupable_type (loc, t)) - res + (check_dupable_ty loc v) in let dup = {apply = (fun k -> IDup (loc, k))} in - typed ctxt loc dup (Item_t (v, stack)) + typed loc dup (Item_t (v, stack)) | Prim (loc, I_DUP, [n], v_annot), (Item_t _ as stack_ty) -> let*? () = check_var_annot loc v_annot in let rec make_proof_argument : @@ -2583,23 +2526,22 @@ and parse_instr : | _ -> 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 + let*$ () = Typecheck_costs.proof_argument n in let*? () = error_unless (Compare.Int.( > ) n 0) (Dup_n_bad_argument loc) in let*? (Dup_n_proof_argument (witness, after_ty)) = record_trace (Dup_n_bad_stack loc) (make_proof_argument n stack_ty) in - let*? res, ctxt = Gas_monad.run ctxt (check_dupable_ty loc after_ty) in - let*? () = + let* () = record_trace_eval (fun () -> let t = serialize_ty_for_error after_ty in Non_dupable_type (loc, t)) - res + (check_dupable_ty loc after_ty) in let dupn = {apply = (fun k -> IDup_n (loc, n, witness, k))} in - typed ctxt loc dupn (Item_t (after_ty, stack_ty)) + typed loc dupn (Item_t (after_ty, stack_ty)) | Prim (loc, I_DIG, [n], result_annot), stack -> let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a, s) dig_proof_argument tzresult @@ -2619,16 +2561,16 @@ and parse_instr : tzfail (Bad_stack (loc, I_DIG, 3, whole_stack)) in let*? n = parse_uint10 n in - let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in + let*$ () = Typecheck_costs.proof_argument n in let*? () = error_unexpected_annot loc result_annot in let*? (Dig_proof_argument (n', x, aft)) = make_proof_argument n stack in let dig = {apply = (fun k -> IDig (loc, n, n', k))} in - typed ctxt loc dig (Item_t (x, aft)) + typed loc dig (Item_t (x, aft)) | Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _ -> tzfail (Invalid_arity (loc, I_DIG, 1, List.length l)) | Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack) -> ( let*? whole_n = parse_uint10 n in - let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument whole_n) in + let*$ () = Typecheck_costs.proof_argument whole_n in let*? () = error_unexpected_annot loc result_annot in match make_dug_proof_argument loc whole_n x whole_stack with | None -> @@ -2636,7 +2578,7 @@ and parse_instr : 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) + typed loc dug aft) | Prim (loc, I_DUG, [_], result_annot), stack -> let*? () = error_unexpected_annot loc result_annot in let stack = serialize_stack_for_error stack in @@ -2647,57 +2589,46 @@ and parse_instr : let*? () = error_unexpected_annot loc annot in let swap = {apply = (fun k -> ISwap (loc, k))} in let stack_ty = Item_t (w, Item_t (v, rest)) in - typed ctxt loc swap stack_ty + typed loc swap stack_ty | Prim (loc, I_PUSH, [t; d], annot), stack -> let*? () = check_var_annot loc annot in - let*? t, ctxt = - Gas_monad.run ctxt - @@ parse_packable_ty ~stack_depth:(stack_depth + 1) ~legacy t + let* (Ex_ty t) = + parse_packable_ty ~stack_depth:(stack_depth + 1) ~legacy t in - let*? (Ex_ty t) = t in - let*? v, ctxt = - Gas_monad.run ctxt - @@ parse_packable_data.parse_packable_data - ~unparse_code_rec - ~elab_conf - ~stack_depth:(stack_depth + 1) - ~allow_forged:false - t - d + let* v = + parse_packable_data.parse_packable_data + ~unparse_code_rec + ~elab_conf + ~stack_depth:(stack_depth + 1) + ~allow_forged:false + t + d in - let*? v in let push = {apply = (fun k -> IPush (loc, t, v, k))} in - typed ctxt loc push (Item_t (t, stack)) + typed loc push (Item_t (t, stack)) | Prim (loc, I_UNIT, [], annot), stack -> let*? () = check_var_type_annot loc annot in let unit = {apply = (fun k -> IUnit (loc, k))} in - typed ctxt loc unit (Item_t (unit_t, stack)) + typed loc unit (Item_t (unit_t, stack)) (* options *) | Prim (loc, I_SOME, [], annot), Item_t (t, rest) -> let*? () = check_var_type_annot loc annot in let cons_some = {apply = (fun k -> ICons_some (loc, k))} in let*? ty = option_t loc t in - typed ctxt loc cons_some (Item_t (ty, rest)) + typed loc cons_some (Item_t (ty, rest)) | Prim (loc, I_NONE, [t], annot), stack -> - let*? t, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy t - in - let*? (Ex_ty t) = t in + let* (Ex_ty t) = parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy t in let*? () = check_var_type_annot loc annot in let cons_none = {apply = (fun k -> ICons_none (loc, t, k))} in let*? ty = option_t loc t in let stack_ty = Item_t (ty, stack) in - typed ctxt loc cons_none stack_ty + typed loc cons_none stack_ty | Prim (loc, I_MAP, [body], annot), Item_t (Option_t (t, _, _), rest) -> ( let*? () = check_kind [Seq_kind] body in let*? () = check_var_type_annot loc annot in - let* judgement, ctxt = - non_terminal_recursion tc_context ctxt body (Item_t (t, rest)) + let* judgement = + non_terminal_recursion tc_context body (Item_t (t, rest)) in - let open Result_syntax in - Lwt.return - @@ match judgement with | Typed ({loc; aft = Item_t (ret, aft_rest); _} as kibody) -> let invalid_map_body () = @@ -2706,15 +2637,12 @@ and parse_instr : in record_trace_eval invalid_map_body - (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* Eq = stack_eq loc 1 aft_rest rest 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 let apply k = IOpt_map {loc; body; k} in - typed_no_lwt ctxt loc {apply} final_stack) + typed loc {apply} final_stack) | Typed {aft = Bot_t; _} -> let aft = serialize_stack_for_error Bot_t in tzfail (Invalid_map_body (loc, aft)) @@ -2724,9 +2652,9 @@ and parse_instr : let*? () = check_kind [Seq_kind] bt in let*? () = check_kind [Seq_kind] bf in let*? () = error_unexpected_annot loc annot in - let* btr, ctxt = non_terminal_recursion tc_context ctxt bt rest in + let* btr = non_terminal_recursion tc_context bt rest in let stack_ty = Item_t (t, rest) in - let* bfr, ctxt = non_terminal_recursion tc_context ctxt bf stack_ty in + let* bfr = non_terminal_recursion tc_context bf stack_ty in let branch ibt ibf = let ifnone = { @@ -2740,18 +2668,14 @@ and parse_instr : in {loc; instr = ifnone; bef; aft = ibt.aft} in - let*? res, ctxt = - Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} - in - let*? res in - return (res, ctxt) + merge_branches loc btr bfr {branch} (* pairs *) | Prim (loc, I_PAIR, [], annot), Item_t (a, Item_t (b, rest)) -> let*? () = check_constr_annot loc annot in let*? (Ty_ex_c ty) = pair_t loc a b in let stack_ty = Item_t (ty, rest) in let cons_pair = {apply = (fun k -> ICons_pair (loc, k))} in - typed ctxt loc cons_pair stack_ty + typed loc cons_pair stack_ty | Prim (loc, I_PAIR, [n], annot), (Item_t _ as stack_ty) -> let*? () = check_var_annot loc annot in let rec make_proof_argument : @@ -2771,13 +2695,13 @@ and parse_instr : | _ -> 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 + let*$ () = Typecheck_costs.proof_argument n in let*? () = error_unless (Compare.Int.( > ) n 1) (Pair_bad_argument loc) in let*? (Comb_proof_argument (witness, after_ty)) = make_proof_argument n stack_ty in let comb = {apply = (fun k -> IComb (loc, n, witness, k))} in - typed ctxt loc comb after_ty + typed loc comb after_ty | Prim (loc, I_UNPAIR, [n], annot), (Item_t _ as stack_ty) -> let*? () = error_unexpected_annot loc annot in let rec make_proof_argument : @@ -2798,7 +2722,7 @@ and parse_instr : | _ -> 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 + let*$ () = Typecheck_costs.proof_argument n in let*? () = error_unless (Compare.Int.( > ) n 1) (Unpair_bad_argument loc) in @@ -2806,11 +2730,11 @@ and parse_instr : make_proof_argument n stack_ty in let uncomb = {apply = (fun k -> IUncomb (loc, n, witness, k))} in - typed ctxt loc uncomb after_ty + typed loc uncomb after_ty | Prim (loc, I_GET, [n], annot), Item_t (comb_ty, rest_ty) -> ( let*? () = check_var_annot loc annot in let*? n = parse_uint11 n in - let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in + let*$ () = Typecheck_costs.proof_argument n in match make_comb_get_proof_argument n comb_ty with | None -> let whole_stack = serialize_stack_for_error stack_ty in @@ -2818,64 +2742,56 @@ and parse_instr : | Some (Comb_get_proof_argument (witness, ty')) -> let after_stack_ty = Item_t (ty', rest_ty) in let comb_get = {apply = (fun k -> IComb_get (loc, n, witness, k))} in - typed ctxt loc comb_get after_stack_ty) + typed loc comb_get after_stack_ty) | ( Prim (loc, I_UPDATE, [n], annot), Item_t (value_ty, Item_t (comb_ty, rest_ty)) ) -> let*? () = check_var_annot loc annot in let*? n = parse_uint11 n in - let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in + let*$ () = Typecheck_costs.proof_argument n in let*? (Comb_set_proof_argument (witness, after_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 - typed ctxt loc comb_set after_stack_ty + typed loc comb_set after_stack_ty | Prim (loc, I_UNPAIR, [], annot), Item_t (Pair_t (a, b, _, _), rest) -> let*? () = check_unpair_annot loc annot in let unpair = {apply = (fun k -> IUnpair (loc, k))} in - typed ctxt loc unpair (Item_t (a, Item_t (b, rest))) + typed loc unpair (Item_t (a, Item_t (b, rest))) | Prim (loc, I_CAR, [], annot), Item_t (Pair_t (a, _, _, _), rest) -> let*? () = check_destr_annot loc annot in let car = {apply = (fun k -> ICar (loc, k))} in - typed ctxt loc car (Item_t (a, rest)) + typed loc car (Item_t (a, rest)) | Prim (loc, I_CDR, [], annot), Item_t (Pair_t (_, b, _, _), rest) -> let*? () = check_destr_annot loc annot in let cdr = {apply = (fun k -> ICdr (loc, k))} in - typed ctxt loc cdr (Item_t (b, rest)) + typed loc cdr (Item_t (b, rest)) (* ors *) | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) -> - let*? tr, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tr + let* (Ex_ty tr) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tr in - let*? (Ex_ty tr) = tr in let*? () = check_constr_annot loc annot in let cons_left = {apply = (fun k -> ICons_left (loc, tr, k))} in let*? (Ty_ex_c ty) = or_t loc tl tr in let stack_ty = Item_t (ty, rest) in - typed ctxt loc cons_left stack_ty + typed loc cons_left stack_ty | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) -> - let*? tl, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tl + let* (Ex_ty tl) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tl in - let*? (Ex_ty tl) = tl in let*? () = check_constr_annot loc annot in let cons_right = {apply = (fun k -> ICons_right (loc, tl, k))} in let*? (Ty_ex_c ty) = or_t loc tl tr in let stack_ty = Item_t (ty, rest) in - typed ctxt loc cons_right stack_ty + typed loc cons_right stack_ty | ( Prim (loc, I_IF_LEFT, [bt; bf], annot), (Item_t (Or_t (tl, tr, _, _), rest) as bef) ) -> let*? () = check_kind [Seq_kind] bt in let*? () = check_kind [Seq_kind] bf in let*? () = error_unexpected_annot loc annot in - let* btr, ctxt = - non_terminal_recursion tc_context ctxt bt (Item_t (tl, rest)) - in - let* bfr, ctxt = - non_terminal_recursion tc_context ctxt bf (Item_t (tr, rest)) - in + let* btr = non_terminal_recursion tc_context bt (Item_t (tl, rest)) in + let* bfr = non_terminal_recursion tc_context bf (Item_t (tr, rest)) in let branch ibt ibf = let instr = { @@ -2889,38 +2805,27 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - let*? res, ctxt = - Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} - in - let*? res in - return (res, ctxt) + merge_branches loc btr bfr {branch} (* lists *) | Prim (loc, I_NIL, [t], annot), stack -> - let*? t, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy t - in - let*? (Ex_ty t) = t in + let* (Ex_ty t) = parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy t in let*? () = check_var_type_annot loc annot in let nil = {apply = (fun k -> INil (loc, t, k))} in let*? ty = list_t loc t in - typed ctxt loc nil (Item_t (ty, stack)) + typed loc nil (Item_t (ty, stack)) | ( Prim (loc, I_CONS, [], annot), Item_t (tv, (Item_t (List_t (t, _), _) as stack)) ) -> - let*? Eq, ctxt = check_item_ty ctxt tv t loc I_CONS 1 2 in + let* Eq = check_item_ty tv t loc I_CONS 1 2 in let*? () = check_var_annot loc annot in let cons_list = {apply = (fun k -> ICons_list (loc, k))} in - (typed ctxt loc cons_list stack - : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc cons_list stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_IF_CONS, [bt; bf], annot), (Item_t (List_t (t, _), rest) as bef) ) -> let*? () = check_kind [Seq_kind] bt in let*? () = check_kind [Seq_kind] bf in let*? () = error_unexpected_annot loc annot in - let* btr, ctxt = - non_terminal_recursion tc_context ctxt bt (Item_t (t, bef)) - in - let* bfr, ctxt = non_terminal_recursion tc_context ctxt bf rest in + let* btr = non_terminal_recursion tc_context bt (Item_t (t, bef)) in + let* bfr = non_terminal_recursion tc_context bf rest in let branch ibt ibf = let instr = { @@ -2934,29 +2839,18 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - let*? res, ctxt = - Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} - in - let*? res in - return (res, ctxt) + merge_branches loc btr bfr {branch} | 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 - typed ctxt loc list_size (Item_t (nat_t, rest)) + typed loc list_size (Item_t (nat_t, rest)) | Prim (loc, I_MAP, [body], annot), Item_t (List_t (elt, _), starting_rest) -> ( let*? () = check_kind [Seq_kind] body in let*? () = check_var_type_annot loc annot in - let* judgement, ctxt = - non_terminal_recursion - tc_context - ctxt - body - (Item_t (elt, starting_rest)) + let* judgement = + non_terminal_recursion tc_context body (Item_t (elt, starting_rest)) in - let open Result_syntax in - Lwt.return - @@ match judgement with | Typed ({aft = Item_t (ret, rest) as aft; _} as kibody) -> let invalid_map_body () = @@ -2965,13 +2859,10 @@ and parse_instr : in record_trace_eval invalid_map_body - (let* eq, ctxt = - Gas_monad.run ctxt @@ stack_eq loc 1 rest starting_rest - in - let* Eq = eq in + (let* Eq = stack_eq loc 1 rest starting_rest in let hloc = loc in let ibody = kibody.instr.apply (IHalt hloc) in - let* ty = list_t loc ret in + let*? ty = list_t loc ret in let list_map = { apply = @@ -2979,7 +2870,7 @@ and parse_instr : } in let stack = Item_t (ty, rest) in - typed_no_lwt ctxt loc list_map stack) + typed loc list_map stack) | Typed {aft; _} -> let aft = serialize_stack_for_error aft in tzfail (Invalid_map_body (loc, aft)) @@ -2987,8 +2878,8 @@ and parse_instr : | Prim (loc, I_ITER, [body], annot), Item_t (List_t (elt, _), rest) -> ( let*? () = check_kind [Seq_kind] body in let*? () = error_unexpected_annot loc annot in - let* judgement, ctxt = - non_terminal_recursion tc_context ctxt body (Item_t (elt, rest)) + let* judgement = + non_terminal_recursion tc_context body (Item_t (elt, rest)) in let mk_list_iter ibody = { @@ -2999,9 +2890,6 @@ and parse_instr : IList_iter (loc, for_logging_only elt, ibody, k)); } in - let open Result_syntax in - Lwt.return - @@ match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = @@ -3011,27 +2899,23 @@ and parse_instr : in record_trace_eval invalid_iter_body - (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 - ) + (let* Eq = stack_eq loc 1 aft rest in + typed loc (mk_list_iter ibody) rest) + | Failed {descr} -> typed loc (mk_list_iter (descr rest)) rest) (* sets *) | Prim (loc, I_EMPTY_SET, [t], annot), rest -> - let*? t, ctxt = - Gas_monad.run ctxt - @@ parse_comparable_ty ~stack_depth:(stack_depth + 1) t + let* (Ex_comparable_ty t) = + parse_comparable_ty ~stack_depth:(stack_depth + 1) t in - let*? (Ex_comparable_ty t) = t in let*? () = check_var_type_annot loc annot in let instr = {apply = (fun k -> IEmpty_set (loc, t, k))} in let*? ty = set_t loc t in - typed ctxt loc instr (Item_t (ty, rest)) + typed loc instr (Item_t (ty, rest)) | Prim (loc, I_ITER, [body], annot), Item_t (Set_t (elt, _), rest) -> ( let*? () = check_kind [Seq_kind] body in let*? () = error_unexpected_annot loc annot in - let* judgement, ctxt = - non_terminal_recursion tc_context ctxt body (Item_t (elt, rest)) + let* judgement = + non_terminal_recursion tc_context body (Item_t (elt, rest)) in let mk_iset_iter ibody = { @@ -3042,9 +2926,6 @@ and parse_instr : ISet_iter (loc, for_logging_only elt, ibody, k)); } in - let open Result_syntax in - Lwt.return - @@ match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = @@ -3054,55 +2935,47 @@ and parse_instr : in record_trace_eval invalid_iter_body - (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 - ) + (let* Eq = stack_eq loc 1 aft rest in + typed loc (mk_iset_iter ibody) rest) + | Failed {descr} -> typed loc (mk_iset_iter (descr rest)) rest) | Prim (loc, I_MEM, [], annot), Item_t (v, Item_t (Set_t (elt, _), rest)) -> let*? () = check_var_type_annot loc annot in - let*? Eq, ctxt = check_item_ty ctxt elt v loc I_MEM 1 2 in + let* Eq = check_item_ty elt v loc I_MEM 1 2 in let instr = {apply = (fun k -> ISet_mem (loc, k))} in - (typed ctxt loc instr (Item_t (bool_t, rest)) - : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr (Item_t (bool_t, rest)) + : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_UPDATE, [], annot), Item_t (v, Item_t (Bool_t, (Item_t (Set_t (elt, _), _) as stack))) ) -> - let*? Eq, ctxt = check_item_ty ctxt elt v loc I_UPDATE 1 3 in + let* Eq = check_item_ty elt v loc I_UPDATE 1 3 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISet_update (loc, k))} in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISet_size (loc, k))} in - typed ctxt loc instr (Item_t (nat_t, rest)) + typed loc instr (Item_t (nat_t, rest)) (* maps *) | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* tk = parse_comparable_ty ~stack_depth:(stack_depth + 1) tk in - let+ tv = parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tv in - (tk, tv) + let* (Ex_comparable_ty tk) = + parse_comparable_ty ~stack_depth:(stack_depth + 1) tk + in + let* (Ex_ty tv) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tv in - let*? Ex_comparable_ty tk, Ex_ty tv = res in let*? () = check_var_type_annot loc annot in let instr = {apply = (fun k -> IEmpty_map (loc, tk, for_logging_only tv, k))} in let*? ty = map_t loc tk tv in - typed ctxt loc instr (Item_t (ty, stack)) + typed loc instr (Item_t (ty, stack)) | Prim (loc, I_MAP, [body], annot), Item_t (Map_t (kt, elt, _), starting_rest) -> ( let*? () = check_kind [Seq_kind] body in let*? () = check_var_type_annot loc annot in let*? (Ty_ex_c ty) = pair_t loc kt elt in - let* judgement, ctxt = - non_terminal_recursion tc_context ctxt body (Item_t (ty, starting_rest)) + let* judgement = + non_terminal_recursion tc_context body (Item_t (ty, starting_rest)) in - let open Result_syntax in - Lwt.return - @@ match judgement with | Typed ({aft = Item_t (ret, rest) as aft; _} as ibody) -> let invalid_map_body () = @@ -3111,11 +2984,8 @@ and parse_instr : in record_trace_eval invalid_map_body - (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* Eq = stack_eq loc 1 rest starting_rest in + let*? ty = map_t loc kt ret in let instr = { apply = @@ -3126,7 +2996,7 @@ and parse_instr : } in let stack = Item_t (ty, rest) in - typed_no_lwt ctxt loc instr stack) + typed loc instr stack) | Typed {aft; _} -> let aft = serialize_stack_for_error aft in tzfail (Invalid_map_body (loc, aft)) @@ -3136,8 +3006,8 @@ and parse_instr : let*? () = check_kind [Seq_kind] body in let*? () = error_unexpected_annot loc annot in let*? (Ty_ex_c ty) = pair_t loc key element_ty in - let* judgement, ctxt = - non_terminal_recursion tc_context ctxt body (Item_t (ty, rest)) + let* judgement = + non_terminal_recursion tc_context body (Item_t (ty, rest)) in let make_instr ibody = { @@ -3148,9 +3018,6 @@ and parse_instr : IMap_iter (loc, for_logging_only ty, ibody, k)); } in - let open Result_syntax in - Lwt.return - @@ match judgement with | Typed ({aft; _} as ibody) -> let invalid_iter_body () = @@ -3160,104 +3027,96 @@ and parse_instr : in record_trace_eval invalid_iter_body - (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) + (let* Eq = stack_eq loc 1 aft rest in + typed loc (make_instr ibody) rest) + | Failed {descr} -> typed loc (make_instr (descr rest)) rest) | Prim (loc, I_MEM, [], annot), Item_t (vk, Item_t (Map_t (k, _, _), rest)) -> - let*? Eq, ctxt = check_item_ty ctxt vk k loc I_MEM 1 2 in + let* Eq = check_item_ty vk k loc I_MEM 1 2 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMap_mem (loc, k))} in - (typed ctxt loc instr (Item_t (bool_t, rest)) - : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr (Item_t (bool_t, rest)) + : ((a, s) judgement, error trace) Gas_monad.t) | Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Map_t (k, elt, _), rest)) -> - let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET 1 2 in + let* Eq = check_item_ty vk k loc I_GET 1 2 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMap_get (loc, k))} in let*? ty = option_t loc elt in let stack = Item_t (ty, rest) in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_UPDATE, [], annot), Item_t ( vk, Item_t (Option_t (vv, _, _), (Item_t (Map_t (k, v, _), _) as stack)) ) ) -> - let*? Eq, ctxt = check_item_ty ctxt vk k loc I_UPDATE 1 3 in - let*? Eq, ctxt = check_item_ty ctxt vv v loc I_UPDATE 2 3 in + let* Eq = check_item_ty vk k loc I_UPDATE 1 3 in + let* Eq = check_item_ty vv v loc I_UPDATE 2 3 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMap_update (loc, k))} in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_GET_AND_UPDATE, [], annot), Item_t ( vk, (Item_t (Option_t (vv, _, _), Item_t (Map_t (k, v, _), _)) as stack) ) ) -> - let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 in - let*? Eq, ctxt = check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 in + let* Eq = check_item_ty vk k loc I_GET_AND_UPDATE 1 3 in + let* Eq = check_item_ty vv v loc I_GET_AND_UPDATE 2 3 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMap_get_and_update (loc, k))} in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _), rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMap_size (loc, k))} in - typed ctxt loc instr (Item_t (nat_t, rest)) + typed loc instr (Item_t (nat_t, rest)) (* big_map *) | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* tk = parse_comparable_ty ~stack_depth:(stack_depth + 1) tk in - let+ tv = - parse_big_map_value_ty ~stack_depth:(stack_depth + 1) ~legacy tv - in - (tk, tv) + let* (Ex_comparable_ty tk) = + parse_comparable_ty ~stack_depth:(stack_depth + 1) tk + in + let* (Ex_ty tv) = + parse_big_map_value_ty ~stack_depth:(stack_depth + 1) ~legacy tv in - let*? Ex_comparable_ty tk, Ex_ty tv = res in let*? () = check_var_type_annot loc annot in let instr = {apply = (fun k -> IEmpty_big_map (loc, tk, tv, k))} in let*? ty = big_map_t loc tk tv in let stack = Item_t (ty, stack) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_MEM, [], annot), Item_t (set_key, Item_t (Big_map_t (k, _, _), rest)) ) -> - let*? Eq, ctxt = check_item_ty ctxt set_key k loc I_MEM 1 2 in + let* Eq = check_item_ty set_key k loc I_MEM 1 2 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBig_map_mem (loc, k))} in let stack = Item_t (bool_t, rest) in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_GET, [], annot), Item_t (vk, Item_t (Big_map_t (k, elt, _), rest)) ) -> - let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET 1 2 in + let* Eq = check_item_ty vk k loc I_GET 1 2 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBig_map_get (loc, k))} in let*? ty = option_t loc elt in let stack = Item_t (ty, rest) in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_UPDATE, [], annot), Item_t ( set_key, Item_t ( Option_t (set_value, _, _), (Item_t (Big_map_t (map_key, map_value, _), _) as stack) ) ) ) -> - let*? Eq, ctxt = check_item_ty ctxt set_key map_key loc I_UPDATE 1 3 in - let*? Eq, ctxt = - check_item_ty ctxt set_value map_value loc I_UPDATE 2 3 - in + let* Eq = check_item_ty set_key map_key loc I_UPDATE 1 3 in + let* Eq = check_item_ty set_value map_value loc I_UPDATE 2 3 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBig_map_update (loc, k))} in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_GET_AND_UPDATE, [], annot), Item_t ( vk, (Item_t (Option_t (vv, _, _), Item_t (Big_map_t (k, v, _), _)) as stack) ) ) -> - let*? Eq, ctxt = check_item_ty ctxt vk k loc I_GET_AND_UPDATE 1 3 in - let*? Eq, ctxt = check_item_ty ctxt vv v loc I_GET_AND_UPDATE 2 3 in + let* Eq = check_item_ty vk k loc I_GET_AND_UPDATE 1 3 in + let* Eq = check_item_ty vv v loc I_GET_AND_UPDATE 2 3 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBig_map_get_and_update (loc, k))} in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) (* Sapling *) | Prim (loc, I_SAPLING_EMPTY_STATE, [memo_size], annot), rest -> let*? memo_size = parse_memo_size memo_size in @@ -3266,7 +3125,7 @@ and parse_instr : {apply = (fun k -> ISapling_empty_state (loc, memo_size, k))} in let stack = Item_t (sapling_state_t ~memo_size, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_SAPLING_VERIFY_UPDATE, [], _), Item_t ( Sapling_transaction_deprecated_t transaction_memo_size, @@ -3284,7 +3143,7 @@ and parse_instr : let*? (Ty_ex_c pair_ty) = pair_t loc int_t state_ty in let*? ty = option_t loc pair_ty in let stack = Item_t (ty, rest) in - typed ctxt loc instr stack + typed loc instr stack else tzfail (Deprecated_instruction T_sapling_transaction_deprecated) | ( Prim (loc, I_SAPLING_VERIFY_UPDATE, [], _), Item_t @@ -3301,39 +3160,34 @@ and parse_instr : let*? (Ty_ex_c pair_ty) = pair_t loc bytes_t pair_ty in let*? ty = option_t loc pair_ty in let stack = Item_t (ty, rest) in - typed ctxt loc instr stack + typed loc instr stack (* control *) | Seq (loc, []), stack -> let instr = {apply = (fun k -> k)} in - typed ctxt loc instr stack - | Seq (_, [single]), stack -> - non_terminal_recursion tc_context ctxt single stack + typed loc instr stack + | Seq (_, [single]), stack -> non_terminal_recursion tc_context single stack | Seq (loc, hd :: tl), stack -> ( - let* judgement, ctxt = non_terminal_recursion tc_context ctxt hd stack in + let* judgement = non_terminal_recursion tc_context hd stack in match judgement with | Failed _ -> tzfail (Fail_not_in_tail_position (Micheline.location hd)) - | Typed ({aft = middle; _} as ihd) -> - let+ judgement, ctxt = + | Typed ({aft = middle; _} as ihd) -> ( + let+ judgement = non_terminal_recursion tc_context - ctxt (Seq (Micheline.dummy_location, tl)) middle in - let judgement = - match judgement with - | Failed {descr} -> - let descr ret = compose_descr loc ihd (descr ret) in - Failed {descr} - | Typed itl -> Typed (compose_descr loc ihd itl) - in - (judgement, ctxt)) + match judgement with + | Failed {descr} -> + let descr ret = compose_descr loc ihd (descr ret) in + Failed {descr} + | Typed itl -> Typed (compose_descr loc ihd itl))) | Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t, rest) as bef) -> let*? () = check_kind [Seq_kind] bt in let*? () = check_kind [Seq_kind] bf in let*? () = error_unexpected_annot loc annot in - let* btr, ctxt = non_terminal_recursion tc_context ctxt bt rest in - let* bfr, ctxt = non_terminal_recursion tc_context ctxt bf rest in + let* btr = non_terminal_recursion tc_context bt rest in + let* bfr = non_terminal_recursion tc_context bf rest in let branch ibt ibf = let instr = { @@ -3347,18 +3201,11 @@ and parse_instr : in {loc; instr; bef; aft = ibt.aft} in - let*? res, ctxt = - Gas_monad.run ctxt @@ merge_branches loc btr bfr {branch} - in - let*? res in - return (res, ctxt) + merge_branches loc btr bfr {branch} | 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 - let* judgement, ctxt = non_terminal_recursion tc_context ctxt body rest in - let open Result_syntax in - Lwt.return - @@ + let* judgement = non_terminal_recursion tc_context body rest in match judgement with | Typed ibody -> let unmatched_branches () = @@ -3368,10 +3215,7 @@ and parse_instr : in record_trace_eval unmatched_branches - (let* eq, ctxt = - Gas_monad.run ctxt @@ stack_eq loc 1 ibody.aft stack - in - let* Eq = eq in + (let* Eq = stack_eq loc 1 ibody.aft stack in let instr = { apply = @@ -3381,7 +3225,7 @@ and parse_instr : ILoop (loc, ibody, k)); } in - typed_no_lwt ctxt loc instr rest) + typed loc instr rest) | Failed {descr} -> let instr = { @@ -3393,17 +3237,14 @@ and parse_instr : ILoop (loc, ibody, k)); } in - typed_no_lwt ctxt loc instr rest) + typed loc instr rest) | ( Prim (loc, I_LOOP_LEFT, [body], annot), (Item_t (Or_t (tl, tr, _, _), rest) as stack) ) -> ( let*? () = check_kind [Seq_kind] body in let*? () = check_var_annot loc annot in - let* judgement, ctxt = - non_terminal_recursion tc_context ctxt body (Item_t (tl, rest)) + let* judgement = + non_terminal_recursion tc_context body (Item_t (tl, rest)) in - let open Result_syntax in - Lwt.return - @@ match judgement with | Typed ibody -> let unmatched_branches () = @@ -3413,10 +3254,7 @@ and parse_instr : in record_trace_eval unmatched_branches - (let* eq, ctxt = - Gas_monad.run ctxt @@ stack_eq loc 1 ibody.aft stack - in - let* Eq = eq in + (let* Eq = stack_eq loc 1 ibody.aft stack in let instr = { apply = @@ -3427,7 +3265,7 @@ and parse_instr : } in let stack = Item_t (tr, rest) in - typed_no_lwt ctxt loc instr stack) + typed loc instr stack) | Failed {descr} -> let instr = { @@ -3440,27 +3278,23 @@ and parse_instr : } in let stack = Item_t (tr, rest) in - typed_no_lwt ctxt loc instr stack) + typed loc instr stack) | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* arg = parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg in - let+ ret = parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret in - (arg, ret) + let* (Ex_ty arg) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg + in + let* (Ex_ty ret) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret in - let*? Ex_ty arg, Ex_ty ret = res in let*? () = check_kind [Seq_kind] code in let*? () = check_var_annot loc annot in - let* kdescr, ctxt = + let* kdescr = parse_kdescr ~unparse_code_rec ~parse_packable_data (Tc_context.add_lambda tc_context) ~elab_conf ~stack_depth:(stack_depth + 1) - ctxt arg ret code @@ -3470,26 +3304,19 @@ and parse_instr : let instr = {apply = (fun k -> ILambda (loc, Lam (kdescr, code), k))} in let*? ty = lambda_t loc arg ret in let stack = Item_t (ty, stack) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; lambda_expr], annot), stack ) -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* arg = - parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr - in - let+ ret = - parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr - in - (arg, ret) + let* (Ex_ty arg) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr + in + let* (Ex_ty ret) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr in - let*? Ex_ty arg, Ex_ty ret = res in let*? () = check_kind [Seq_kind] lambda_expr in let*? () = check_var_annot loc annot in let*? lambda_rec_ty = lambda_t loc arg ret in - let* code, ctxt = + let* code = parse_lam_rec ~unparse_code_rec: (fun ~stack_depth:_ ~elab_conf:_ _unparsing_mode node -> @@ -3500,7 +3327,6 @@ and parse_instr : Tc_context.(add_lambda tc_context) ~elab_conf ~stack_depth:(stack_depth + 1) - ctxt arg ret lambda_rec_ty @@ -3508,21 +3334,21 @@ and parse_instr : in let instr = {apply = (fun k -> ILambda (loc, code, k))} in let stack = Item_t (lambda_rec_ty, stack) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_EXEC, [], annot), Item_t (arg, Item_t (Lambda_t (param, ret, _), rest)) ) -> - let*? Eq, ctxt = check_item_ty ctxt arg param loc I_EXEC 1 2 in + let* Eq = check_item_ty arg param loc I_EXEC 1 2 in let*? () = check_var_annot loc annot in let stack = Item_t (ret, rest) in let instr = {apply = (fun k -> IExec (loc, for_logging_only stack, k))} in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, I_APPLY, [], annot), Item_t ( capture, Item_t (Lambda_t (Pair_t (capture_ty, arg_ty, _, _), ret, _), rest) ) ) -> let*? () = check_packable ~allow_contract:false loc capture_ty in - let*? Eq, ctxt = check_item_ty ctxt capture capture_ty loc I_APPLY 1 2 in + let* Eq = check_item_ty capture capture_ty loc I_APPLY 1 2 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IApply (loc, capture_ty, k))} in let*? res_ty = @@ -3532,11 +3358,11 @@ and parse_instr : would be a smart deconstructor to ensure this statically. *) in let stack = Item_t (res_ty, rest) in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | Prim (loc, I_DIP, [code], annot), Item_t (v, rest) -> ( let*? () = error_unexpected_annot loc annot in let*? () = check_kind [Seq_kind] code in - let* judgement, ctxt = non_terminal_recursion tc_context ctxt code rest in + let* judgement = non_terminal_recursion tc_context code rest in match judgement with | Typed descr -> let instr = @@ -3548,47 +3374,43 @@ and parse_instr : } in let stack = Item_t (v, descr.aft) in - typed ctxt loc instr stack + typed loc instr stack | Failed _ -> tzfail (Fail_not_in_tail_position loc)) | Prim (loc, I_DIP, [n; code], result_annot), stack -> let*? n = parse_uint10 n in - let*? ctxt = Gas.consume ctxt (Typecheck_costs.proof_argument n) in + let*$ () = Typecheck_costs.proof_argument n in let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> - context -> - ((a, s) dipn_proof_argument * context) tzresult Lwt.t = - fun n stk ctxt -> + ((a, s) dipn_proof_argument, error trace) Gas_monad.t = + fun n stk -> match (Compare.Int.(n = 0), stk) with | true, rest -> ( - let* judgement, ctxt = - non_terminal_recursion tc_context ctxt code rest - in + let* judgement = non_terminal_recursion tc_context code rest in match judgement with | Typed descr -> return - ( (Dipn_proof_argument (KRest, descr, descr.aft) - : (a, s) dipn_proof_argument), - ctxt ) + (Dipn_proof_argument (KRest, descr, descr.aft) + : (a, s) dipn_proof_argument) | Failed _ -> tzfail (Fail_not_in_tail_position loc)) | false, Item_t (v, rest) -> - let+ Dipn_proof_argument (n', descr, aft'), ctxt = - make_proof_argument (n - 1) rest ctxt + let+ (Dipn_proof_argument (n', descr, aft')) = + make_proof_argument (n - 1) rest in let w = KPrefix (loc, v, n') in - (Dipn_proof_argument (w, descr, Item_t (v, aft')), ctxt) + Dipn_proof_argument (w, descr, Item_t (v, aft')) | _, _ -> 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', descr, aft), ctxt = - make_proof_argument n stack ctxt + let* (Dipn_proof_argument (n', descr, aft)) = + make_proof_argument n stack in let b = descr.instr.apply (IHalt descr.loc) in let res = {apply = (fun k -> IDipn (loc, n, n', b, k))} in - typed ctxt loc res aft + typed loc res aft | Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _ -> (* Technically, the arities 1 and 2 are allowed but the error only mentions 2. However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *) @@ -3599,391 +3421,384 @@ and parse_instr : let instr = {apply = (fun _k -> IFailwith (loc, v))} in let descr aft = {loc; instr; bef = stack_ty; aft} in log_stack loc stack_ty Bot_t ; - return (Failed {descr}, ctxt) + return (Failed {descr}) | Prim (loc, I_NEVER, [], annot), Item_t (Never_t, _rest) -> let*? () = error_unexpected_annot loc annot in let instr = {apply = (fun _k -> INever loc)} in let descr aft = {loc; instr; bef = stack_ty; aft} in log_stack loc stack_ty Bot_t ; - return (Failed {descr}, ctxt) + return (Failed {descr}) (* timestamp operations *) | Prim (loc, I_ADD, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_timestamp_to_seconds (loc, k))} in - typed ctxt loc instr (Item_t (Timestamp_t, rest)) + typed loc instr (Item_t (Timestamp_t, rest)) | ( Prim (loc, I_ADD, [], annot), Item_t (Int_t, (Item_t (Timestamp_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_seconds_to_timestamp (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t, Item_t (Int_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISub_timestamp_seconds (loc, k))} in let stack = Item_t (Timestamp_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_SUB, [], annot), Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IDiff_timestamps (loc, k))} in let stack = Item_t (int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack (* string operations *) | ( Prim (loc, I_CONCAT, [], annot), Item_t (String_t, (Item_t (String_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IConcat_string_pair (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_CONCAT, [], annot), Item_t (List_t (String_t, _), rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IConcat_string (loc, k))} in - typed ctxt loc instr (Item_t (String_t, rest)) + typed loc instr (Item_t (String_t, rest)) | ( Prim (loc, I_SLICE, [], annot), Item_t (Nat_t, Item_t (Nat_t, Item_t (String_t, rest))) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISlice_string (loc, k))} in let stack = Item_t (option_string_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SIZE, [], annot), Item_t (String_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IString_size (loc, k))} in let stack = Item_t (nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack (* bytes operations *) | ( Prim (loc, I_CONCAT, [], annot), Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IConcat_bytes_pair (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_CONCAT, [], annot), Item_t (List_t (Bytes_t, _), rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IConcat_bytes (loc, k))} in let stack = Item_t (Bytes_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_SLICE, [], annot), Item_t (Nat_t, Item_t (Nat_t, Item_t (Bytes_t, rest))) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISlice_bytes (loc, k))} in let stack = Item_t (option_bytes_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBytes_size (loc, k))} in let stack = Item_t (nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_BYTES, [], annot), Item_t (Nat_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBytes_nat (loc, k))} in let stack = Item_t (bytes_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NAT, [], annot), Item_t (Bytes_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INat_bytes (loc, k))} in let stack = Item_t (nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_BYTES, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBytes_int (loc, k))} in let stack = Item_t (bytes_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_INT, [], annot), Item_t (Bytes_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IInt_bytes (loc, k))} in let stack = Item_t (int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack (* currency operations *) | ( Prim (loc, I_ADD, [], annot), Item_t (Mutez_t, (Item_t (Mutez_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_tez (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_SUB, [], annot), Item_t (Mutez_t, (Item_t (Mutez_t, _) as stack)) ) -> if legacy (* Legacy check introduced in Ithaca. *) then let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISub_tez_legacy (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack else tzfail (Deprecated_instruction I_SUB) | Prim (loc, I_SUB_MUTEZ, [], annot), Item_t (Mutez_t, Item_t (Mutez_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISub_tez (loc, k))} in let stack = Item_t (option_mutez_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest)) -> (* no type name check *) let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_teznat (loc, k))} in let stack = Item_t (Mutez_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Mutez_t, _) as stack)) -> (* no type name check *) let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_nattez (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack (* boolean operations *) | Prim (loc, I_OR, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IOr (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_AND, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAnd (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_XOR, [], annot), Item_t (Bool_t, (Item_t (Bool_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IXor (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NOT, [], annot), (Item_t (Bool_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INot (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack (* integer operations *) | Prim (loc, I_ABS, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAbs_int (loc, k))} in let stack = Item_t (nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_ISNAT, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IIs_nat (loc, k))} in let stack = Item_t (option_nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_INT, [], annot), Item_t (Nat_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IInt_nat (loc, k))} in let stack = Item_t (int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NEG, [], annot), (Item_t (Int_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INeg (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NEG, [], annot), Item_t (Nat_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INeg (loc, k))} in let stack = Item_t (int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_ADD, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_int (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_ADD, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_int (loc, k))} in let stack = Item_t (Int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_int (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_ADD, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SUB, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISub_int (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SUB, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISub_int (loc, k))} in let stack = Item_t (Int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISub_int (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SUB, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISub_int (loc, k))} in let stack = Item_t (int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Int_t, (Item_t (Int_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_int (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_int (loc, k))} in let stack = Item_t (Int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Int_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IEdiv_teznat (loc, k))} in let stack = Item_t (option_pair_mutez_mutez_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_EDIV, [], annot), Item_t (Mutez_t, Item_t (Mutez_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IEdiv_tez (loc, k))} in let stack = Item_t (option_pair_nat_mutez_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Int_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IEdiv_int (loc, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_EDIV, [], annot), Item_t (Int_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IEdiv_int (loc, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Int_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IEdiv_nat (loc, k))} in let stack = Item_t (option_pair_int_nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_EDIV, [], annot), Item_t (Nat_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IEdiv_nat (loc, k))} in let stack = Item_t (option_pair_nat_nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_LSL, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ILsl_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_LSL, [], annot), Item_t (Bytes_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ILsl_bytes (loc, k))} in let stack = Item_t (Bytes_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_LSR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ILsr_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_LSR, [], annot), Item_t (Bytes_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ILsr_bytes (loc, k))} in let stack = Item_t (Bytes_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_OR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IOr_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_OR, [], annot), Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IOr_bytes (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_AND, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAnd_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_AND, [], annot), Item_t (Int_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAnd_int_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_AND, [], annot), Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAnd_bytes (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_XOR, [], annot), Item_t (Nat_t, (Item_t (Nat_t, _) as stack)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IXor_nat (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_XOR, [], annot), Item_t (Bytes_t, (Item_t (Bytes_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IXor_bytes (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NOT, [], annot), (Item_t (Int_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INot_int (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NOT, [], annot), Item_t (Nat_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INot_int (loc, k))} in let stack = Item_t (int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NOT, [], annot), (Item_t (Bytes_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INot_bytes (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack (* comparison *) | Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest)) -> let*? () = check_var_annot loc annot in - let*? Eq, ctxt = check_item_ty ctxt t1 t2 loc I_COMPARE 1 2 in + let* Eq = check_item_ty t1 t2 loc I_COMPARE 1 2 in let*? Eq = check_comparable loc t1 in let instr = {apply = (fun k -> ICompare (loc, t1, k))} in let stack = Item_t (int_t, rest) in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) (* comparators *) | Prim (loc, I_EQ, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IEq (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NEQ, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INeq (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_LT, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ILt (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_GT, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IGt (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_LE, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ILe (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_GE, [], annot), Item_t (Int_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IGe (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> let*? () = check_var_annot loc annot in - let*? res, ctxt = - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* (Ex_ty cast_t) = - parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy cast_t - in - let+ Eq = ty_eq ~error_details:(Informative loc) cast_t t in - () + let* (Ex_ty cast_t) = + parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy cast_t in - let*? () = res in + let* Eq = ty_eq ~error_details:(Informative loc) cast_t t in (* We can reuse [stack] because [a ty = b ty] means [a = b]. *) let instr = {apply = (fun k -> k)} in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | Prim (loc, I_RENAME, [], annot), (Item_t _ as stack) -> let*? () = check_var_annot loc annot in (* can erase annot *) let instr = {apply = (fun k -> k)} in - typed ctxt loc instr stack + typed loc instr stack (* packing *) | Prim (loc, I_PACK, [], annot), Item_t (t, rest) -> let*? () = @@ -3995,46 +3810,39 @@ and parse_instr : let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IPack (loc, t, k))} in let stack = Item_t (bytes_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) -> - let*? t, ctxt = - Gas_monad.run ctxt - @@ parse_packable_ty ~stack_depth:(stack_depth + 1) ~legacy ty + let* (Ex_ty t) = + parse_packable_ty ~stack_depth:(stack_depth + 1) ~legacy ty in - let*? (Ex_ty t) = t in let*? () = check_var_type_annot loc annot in let*? res_ty = option_t loc t in let instr = {apply = (fun k -> IUnpack (loc, t, k))} in let stack = Item_t (res_ty, rest) in - typed ctxt loc instr stack + typed loc instr stack (* protocol *) | Prim (loc, I_ADDRESS, [], annot), Item_t (Contract_t _, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAddress (loc, k))} in let stack = Item_t (address_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) -> - let*? t, ctxt = - Gas_monad.run ctxt - @@ parse_passable_ty ~stack_depth:(stack_depth + 1) ~legacy ty + let* (Ex_ty t) = + parse_passable_ty ~stack_depth:(stack_depth + 1) ~legacy ty in - let*? (Ex_ty t) = t in let*? contract_ty = contract_t loc t in let*? res_ty = option_t loc contract_ty in let*? entrypoint = parse_entrypoint_annot_strict loc annot in let instr = {apply = (fun k -> IContract (loc, t, entrypoint, k))} in let stack = Item_t (res_ty, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( 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 = 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 + let* name = parse_view_name name in + let* (Ex_ty output_ty) = + parse_view_output_ty ~stack_depth:0 ~legacy output_ty in - let*? (Ex_ty output_ty) = output_ty in let*? res_ty = option_t output_ty_loc output_ty in let*? () = check_var_annot loc annot in let instr = @@ -4049,29 +3857,29 @@ and parse_instr : } in let stack = Item_t (res_ty, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, (I_TRANSFER_TOKENS as prim), [], annot), Item_t (p, Item_t (Mutez_t, Item_t (Contract_t (cp, _), rest))) ) -> let*? () = Tc_context.check_not_in_view loc ~legacy tc_context prim in - let*? Eq, ctxt = check_item_ty ctxt p cp loc prim 1 4 in + let* Eq = check_item_ty p cp loc prim 1 4 in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ITransfer_tokens (loc, k))} in let stack = Item_t (operation_t, rest) in - (typed ctxt loc instr stack : ((a, s) judgement * context) tzresult Lwt.t) + (typed loc instr stack : ((a, s) judgement, error trace) Gas_monad.t) | ( Prim (loc, (I_SET_DELEGATE as prim), [], annot), Item_t (Option_t (Key_hash_t, _, _), rest) ) -> let*? () = Tc_context.check_not_in_view loc ~legacy tc_context prim in let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISet_delegate (loc, k))} in let stack = Item_t (operation_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (_, I_CREATE_ACCOUNT, _, _), _ -> tzfail (Deprecated_instruction I_CREATE_ACCOUNT) | Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IImplicit_account (loc, k))} in let stack = Item_t (contract_unit_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, (I_CREATE_CONTRACT as prim), [(Seq _ as code)], annot), Item_t (Option_t (Key_hash_t, _, _), Item_t (Mutez_t, Item_t (ginit, rest))) ) @@ -4082,85 +3890,65 @@ 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*? 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 () -> - Ill_formed_type - (Some "parameter", canonical_code, location arg_type)) - @@ parse_parameter_ty_and_entrypoints - ~stack_depth:(stack_depth + 1) - ~legacy - arg_type - in - let+ storage_type = - Gas_monad.record_trace_eval ~error_details (fun () -> - Ill_formed_type - (Some "storage", canonical_code, location storage_type)) - @@ parse_storage_ty - ~stack_depth:(stack_depth + 1) - ~legacy - storage_type - in - (arg_type, storage_type, code_field, views) + let* {arg_type; storage_type; code_field; views} = + parse_toplevel canonical_code + in + let* (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = + Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> + Ill_formed_type (Some "parameter", canonical_code, location arg_type)) + @@ parse_parameter_ty_and_entrypoints + ~stack_depth:(stack_depth + 1) + ~legacy + arg_type in - let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type, - code_field, - views ) = - res + let* (Ex_ty storage_type) = + Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> + Ill_formed_type + (Some "storage", canonical_code, location storage_type)) + @@ parse_storage_ty ~stack_depth:(stack_depth + 1) ~legacy storage_type in let*? (Ty_ex_c arg_type_full) = pair_t loc arg_type storage_type in let*? (Ty_ex_c ret_type_full) = pair_t loc list_operation_t storage_type in let* result = - trace - (Ill_typed_contract (canonical_code, [])) - (parse_kdescr + Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> + Ill_typed_contract (canonical_code, [])) + @@ parse_kdescr ~unparse_code_rec ~parse_packable_data (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints) - ctxt ~elab_conf ~stack_depth:(stack_depth + 1) arg_type_full ret_type_full - code_field) + code_field in match result with - | {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, ctxt -> + | {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _} -> let views_result = parse_views ~unparse_code_rec ~parse_packable_data - ctxt ~elab_conf storage_type views in - let* _typed_views, ctxt = - trace (Ill_typed_contract (canonical_code, [])) views_result + let* _typed_views = + Gas_monad.record_trace_eval + ~error_details:(Informative ()) + (fun () -> Ill_typed_contract (canonical_code, [])) + views_result in - let*? storage_eq, ctxt = + let* Eq = let error_details = Informative loc in - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in let* Eq = ty_eq ~error_details arg arg_type_full in let* Eq = ty_eq ~error_details ret ret_type_full in ty_eq ~error_details storage_type ginit in - let*? Eq = storage_eq in let instr = { apply = @@ -4169,15 +3957,14 @@ and parse_instr : } in let stack = Item_t (operation_t, Item_t (address_t, rest)) in - typed ctxt loc instr stack) + typed loc instr stack) | Prim (loc, I_NOW, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INow (loc, k))} in let stack = Item_t (timestamp_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MIN_BLOCK_TIME, [], _), stack -> typed - ctxt loc {apply = (fun k -> IMin_block_time (loc, k))} (Item_t (nat_t, stack)) @@ -4185,44 +3972,44 @@ and parse_instr : let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAmount (loc, k))} in let stack = Item_t (mutez_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_CHAIN_ID, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IChainId (loc, k))} in let stack = Item_t (chain_id_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_BALANCE, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBalance (loc, k))} in let stack = Item_t (mutez_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_LEVEL, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ILevel (loc, k))} in let stack = Item_t (nat_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_VOTING_POWER, [], annot), Item_t (Key_hash_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IVoting_power (loc, k))} in let stack = Item_t (nat_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_TOTAL_VOTING_POWER, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ITotal_voting_power (loc, k))} in let stack = Item_t (nat_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (_, I_STEPS_TO_QUOTA, _, _), _ -> tzfail (Deprecated_instruction I_STEPS_TO_QUOTA) | Prim (loc, I_SOURCE, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISource (loc, k))} in let stack = Item_t (address_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SENDER, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISender (loc, k))} in let stack = Item_t (address_t, stack) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, (I_SELF as prim), [], annot), stack -> ( let*? entrypoint = parse_entrypoint_annot_lax loc annot in let open Tc_context in @@ -4237,136 +4024,134 @@ and parse_instr : | View -> tzfail (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> - let*? r, ctxt = - Gas_monad.run ctxt - @@ find_entrypoint - ~error_details:(Informative ()) - param_type - entrypoints - entrypoint + let* (Ex_ty_cstr {ty = param_type; _}) = + find_entrypoint + ~error_details:(Informative ()) + param_type + entrypoints + entrypoint in - let*? (Ex_ty_cstr {ty = param_type; _}) = r in let*? res_ty = contract_t loc param_type in let instr = {apply = (fun k -> ISelf (loc, param_type, entrypoint, k))} in let stack = Item_t (res_ty, stack) in - typed ctxt loc instr stack) + typed loc instr stack) | Prim (loc, I_SELF_ADDRESS, [], annot), stack -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISelf_address (loc, k))} in let stack = Item_t (address_t, stack) in - typed ctxt loc instr stack + typed loc instr stack (* cryptography *) | Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IHash_key (loc, k))} in let stack = Item_t (key_hash_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_CHECK_SIGNATURE, [], annot), Item_t (Key_t, Item_t (Signature_t, Item_t (Bytes_t, rest))) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ICheck_signature (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_BLAKE2B, [], annot), (Item_t (Bytes_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IBlake2b (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SHA256, [], annot), (Item_t (Bytes_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISha256 (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SHA512, [], annot), (Item_t (Bytes_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISha512 (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_KECCAK, [], annot), (Item_t (Bytes_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IKeccak (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_SHA3, [], annot), (Item_t (Bytes_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> ISha3 (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_ADD, [], annot), Item_t (Bls12_381_g1_t, (Item_t (Bls12_381_g1_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_bls12_381_g1 (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_ADD, [], annot), Item_t (Bls12_381_g2_t, (Item_t (Bls12_381_g2_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_bls12_381_g2 (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_ADD, [], annot), Item_t (Bls12_381_fr_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IAdd_bls12_381_fr (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_g1_t, Item_t (Bls12_381_fr_t, rest)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_bls12_381_g1 (loc, k))} in let stack = Item_t (Bls12_381_g1_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_g2_t, Item_t (Bls12_381_fr_t, rest)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_bls12_381_g2 (loc, k))} in let stack = Item_t (Bls12_381_g2_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_bls12_381_fr (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_MUL, [], annot), Item_t (Nat_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_bls12_381_fr_z (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_MUL, [], annot), Item_t (Int_t, (Item_t (Bls12_381_fr_t, _) as stack)) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_bls12_381_fr_z (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Int_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_bls12_381_z_fr (loc, k))} in let stack = Item_t (Bls12_381_fr_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_MUL, [], annot), Item_t (Bls12_381_fr_t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IMul_bls12_381_z_fr (loc, k))} in let stack = Item_t (Bls12_381_fr_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_INT, [], annot), Item_t (Bls12_381_fr_t, rest) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IInt_bls12_381_fr (loc, k))} in let stack = Item_t (int_t, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g1_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INeg_bls12_381_g1 (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_g2_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INeg_bls12_381_g2 (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_NEG, [], annot), (Item_t (Bls12_381_fr_t, _) as stack) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> INeg_bls12_381_fr (loc, k))} in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_PAIRING_CHECK, [], annot), Item_t (List_t (Pair_t (Bls12_381_g1_t, Bls12_381_g2_t, _, _), _), rest) ) -> let*? () = check_var_annot loc annot in let instr = {apply = (fun k -> IPairing_check_bls12_381 (loc, k))} in let stack = Item_t (bool_t, rest) in - typed ctxt loc instr stack + typed loc instr stack (* Tickets *) | Prim (loc, I_TICKET, [], annot), Item_t (t, Item_t (Nat_t, rest)) -> let*? () = check_var_annot loc annot in @@ -4375,7 +4160,7 @@ and parse_instr : let instr = {apply = (fun k -> ITicket (loc, for_logging_only t, k))} in let*? res_ty = option_t loc res_ty in let stack = Item_t (res_ty, rest) in - typed ctxt loc instr stack + typed loc instr stack | Prim (loc, I_TICKET_DEPRECATED, [], annot), Item_t (t, Item_t (Nat_t, rest)) -> if legacy then @@ -4386,7 +4171,7 @@ and parse_instr : {apply = (fun k -> ITicket_deprecated (loc, for_logging_only t, k))} in let stack = Item_t (res_ty, rest) in - typed ctxt loc instr stack + typed loc instr stack else tzfail (Deprecated_instruction I_TICKET_DEPRECATED) | ( Prim (loc, I_READ_TICKET, [], annot), (Item_t (Ticket_t (t, _), _) as full_stack) ) -> @@ -4397,7 +4182,7 @@ and parse_instr : {apply = (fun k -> IRead_ticket (loc, for_logging_only t, k))} in let stack = Item_t (result, full_stack) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_SPLIT_TICKET, [], annot), Item_t ( (Ticket_t (t, _) as ticket_t), @@ -4408,7 +4193,7 @@ and parse_instr : let*? res_ty = option_t loc pair_tickets_ty in let instr = {apply = (fun k -> ISplit_ticket (loc, k))} in let stack = Item_t (res_ty, rest) in - typed ctxt loc instr stack + typed loc instr stack | ( Prim (loc, I_JOIN_TICKETS, [], annot), Item_t ( Pair_t @@ -4418,47 +4203,41 @@ and parse_instr : _ ), rest ) ) -> let*? () = check_var_annot loc annot in - let*? eq, ctxt = - Gas_monad.run ctxt - @@ ty_eq ~error_details:(Informative loc) contents_ty_a contents_ty_b + let* Eq = + ty_eq ~error_details:(Informative loc) contents_ty_a contents_ty_b in - let*? Eq = eq in let*? res_ty = option_t loc ty_a in let instr = {apply = (fun k -> IJoin_tickets (loc, contents_ty_a, k))} in let stack = Item_t (res_ty, rest) in - typed ctxt loc instr stack + typed loc instr stack (* Timelocks *) | ( Prim (loc, I_OPEN_CHEST, [], _), Item_t (Chest_key_t, Item_t (Chest_t, Item_t (Nat_t, rest))) ) -> let instr = {apply = (fun k -> IOpen_chest (loc, k))} in - typed ctxt loc instr (Item_t (option_bytes_t, rest)) + typed loc instr (Item_t (option_bytes_t, rest)) (* Events *) | Prim (loc, I_EMIT, [], annot), Item_t (data, rest) -> let*? () = check_packable ~allow_contract:false loc data in let*? tag = parse_entrypoint_annot_strict loc annot in - let*? unparsed_ty, ctxt = - Gas_monad.run_pure ctxt @@ unparse_ty ~loc:() data - in - let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed_ty) in + let* unparsed_ty = unparse_ty ~loc:() data in + let*$ () = Script.strip_locations_cost unparsed_ty in let unparsed_ty = Micheline.strip_locations unparsed_ty in let instr = {apply = (fun k -> IEmit {loc; tag; ty = data; unparsed_ty; k})} in - typed ctxt loc instr (Item_t (Operation_t, rest)) + typed loc instr (Item_t (Operation_t, rest)) | Prim (loc, I_EMIT, [ty_node], annot), Item_t (data, rest) -> - let*? ty, ctxt = - Gas_monad.run ctxt - @@ parse_packable_ty ~stack_depth:(stack_depth + 1) ~legacy ty_node + let* (Ex_ty ty) = + parse_packable_ty ~stack_depth:(stack_depth + 1) ~legacy ty_node in - let*? (Ex_ty ty) = ty in - let*? Eq, ctxt = check_item_ty ctxt ty data loc I_EMIT 1 2 in + let* Eq = check_item_ty ty data loc I_EMIT 1 2 in let*? tag = parse_entrypoint_annot_strict loc annot in - let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost ty_node) in + let*$ () = Script.strip_locations_cost ty_node in let unparsed_ty = Micheline.strip_locations ty_node in let instr = {apply = (fun k -> IEmit {loc; tag; ty = data; unparsed_ty; k})} in - typed ctxt loc instr (Item_t (Operation_t, rest)) + typed loc instr (Item_t (Operation_t, rest)) (* Primitive parsing errors *) | ( Prim ( loc, @@ -4709,35 +4488,12 @@ module type GAS_MONAD = sig ('key, 'value1) map -> (('key, 'value2) map, error trace) t - val parse_kdescr : - unparse_code_rec:unparse_code_rec -> - parse_packable_data:parse_packable_data -> - elab_conf:elab_conf -> - stack_depth:int -> - tc_context -> - ('arg, 'argc) ty -> - ('ret, 'retc) ty -> - Script.node -> - (('arg, end_of_stack, 'ret, end_of_stack) kdescr, error trace) t - val normalized_lam : unparse_code_rec:unparse_code_rec -> stack_depth:int -> ('a, end_of_stack, 'b, end_of_stack) kdescr -> Script.node -> (('a, 'b) lambda, error trace) t - - val parse_lam_rec : - unparse_code_rec:Script_ir_unparser.unparse_code_rec -> - parse_packable_data:parse_packable_data -> - elab_conf:elab_conf -> - stack_depth:int -> - tc_context -> - ('arg, 'argc) ty -> - ('ret, 'retc) ty -> - (('arg, 'ret) lambda, Dependent_bool.no) ty -> - Script.node -> - (('arg, 'ret) lambda, error trace) t end module GM : GAS_MONAD with type ('a, 'trace) t = ('a, 'trace) Gas_monad.t = @@ -4764,16 +4520,8 @@ struct let map_map = Script_map.map_in_gas_monad - let parse_kdescr ~unparse_code_rec:_ ~parse_packable_data:_ ~elab_conf:_ - ~stack_depth:_ _tc_context _ta _tr _node = - assert false - let normalized_lam ~unparse_code_rec:_ ~stack_depth:_ _kdescr _script_instr = assert false - - let parse_lam_rec ~unparse_code_rec:_ ~parse_packable_data:_ ~elab_conf:_ - ~stack_depth:_ _tc_context _arg_ty _ret_ty _lam_ty _node = - assert false end module LGM : @@ -4845,35 +4593,8 @@ struct let map_map f m ctxt = Script_map.map_es_in_context (fun ctxt k v -> f k v ctxt) ctxt m - let parse_kdescr ~unparse_code_rec ~parse_packable_data ~elab_conf - ~stack_depth tc_context ta tr node ctxt = - parse_kdescr - ~unparse_code_rec - ~parse_packable_data - ~elab_conf - ~stack_depth - tc_context - ctxt - ta - tr - node - let normalized_lam ~unparse_code_rec ~stack_depth kdescr script_instr ctxt = normalized_lam ~unparse_code_rec ~stack_depth ctxt kdescr script_instr - - let parse_lam_rec ~unparse_code_rec ~parse_packable_data ~elab_conf - ~stack_depth tc_context arg_ty ret_ty lam_ty node ctxt = - parse_lam_rec - ~unparse_code_rec - ~parse_packable_data - ~elab_conf - ~stack_depth - tc_context - ctxt - arg_ty - ret_ty - lam_ty - node end module Data_parser (M : GAS_MONAD) = struct @@ -5188,7 +4909,7 @@ module Data_parser (M : GAS_MONAD) = struct (* Lambdas *) | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> let* kdescr = - traced + traced @@ from_gas_monad @@ parse_kdescr ~unparse_code_rec ~parse_packable_data @@ -5208,16 +4929,17 @@ module Data_parser (M : GAS_MONAD) = struct Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) -> traced @@ let*? lambda_rec_ty = lambda_t loc ta tr in - parse_lam_rec - ~unparse_code_rec - ~parse_packable_data - Tc_context.(add_lambda data) - ~elab_conf - ~stack_depth:(stack_depth + 1) - ta - tr - lambda_rec_ty - script_instr + from_gas_monad + @@ parse_lam_rec + ~unparse_code_rec + ~parse_packable_data + Tc_context.(add_lambda data) + ~elab_conf + ~stack_depth:(stack_depth + 1) + ta + tr + lambda_rec_ty + script_instr | Lambda_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) @@ -5475,20 +5197,19 @@ let parse_code : let*? (Ty_ex_c ret_type_full) = pair_t storage_type_loc list_operation_t storage_type in - let* kdescr, ctxt = - trace - (Ill_typed_contract (code, [])) - (parse_kdescr + 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 - ctxt ~stack_depth:0 arg_type_full ret_type_full - code_field) + code_field 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 @@ -5584,76 +5305,66 @@ 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 type_map = ref [] in let*? res, ctxt = Gas_monad.run ctxt @@ let open Gas_monad.Syntax in + let type_map = ref [] 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 () -> + let error_details = Informative () in + let* (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = + Gas_monad.record_trace_eval ~error_details (fun () -> Ill_formed_type (Some "parameter", code, arg_type_loc)) @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type in - let+ ex_storage_type = - Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> + let* (Ex_ty storage_type) = + Gas_monad.record_trace_eval ~error_details (fun () -> Ill_formed_type (Some "storage", code, storage_type_loc)) @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type in - (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, - toplevel, - 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 type_logger loc ~stack_ty_before ~stack_ty_after = - 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 ctxt - in - let result = - parse_kdescr - ~unparse_code_rec - ~parse_packable_data:{parse_packable_data} - (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints) - ctxt - ~elab_conf - ~stack_depth:0 - arg_type_full - ret_type_full - code_field - in - let* (_ : (_, _, _, _) kdescr), ctxt = - trace (Ill_typed_contract (code, !type_map)) result - in - let views_result = - parse_views - ~unparse_code_rec - ~parse_packable_data:{parse_packable_data} - ctxt - ~elab_conf - storage_type - views - in - let+ typed_views, ctxt = - trace (Ill_typed_contract (code, !type_map)) views_result - in - ( Typechecked_code_internal + 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 type_logger loc ~stack_ty_before ~stack_ty_after = + 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 ctxt + in + let* (_ : (_, _, _, _) kdescr) = + Gas_monad.record_trace_eval ~error_details (fun () -> + Ill_typed_contract (code, !type_map)) + @@ 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+ typed_views = + Gas_monad.record_trace_eval ~error_details (fun () -> + Ill_typed_contract (code, !type_map)) + @@ parse_views + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data} + ~elab_conf + storage_type + views + in + Typechecked_code_internal { toplevel; arg_type; @@ -5661,8 +5372,10 @@ let typecheck_code : entrypoints; typed_views; type_map = !type_map; - }, - ctxt ) + } + in + let*? res in + return (res, ctxt) (* Uncarbonated because used only in RPCs *) let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) @@ -6279,22 +5992,32 @@ let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] let parse_view ~elab_conf ctxt ty view = - parse_view - ~unparse_code_rec - ~parse_packable_data:{parse_packable_data} - ~elab_conf - ctxt - ty - view + let open Lwt_result_syntax in + let*? view, ctxt = + Gas_monad.run ctxt + @@ parse_view + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data} + ~elab_conf + ty + view + in + let*? view in + return (view, ctxt) let parse_views ~elab_conf ctxt ty views = - parse_views - ~unparse_code_rec - ~parse_packable_data:{parse_packable_data} - ~elab_conf - ctxt - ty - views + let open Lwt_result_syntax in + let*? views, ctxt = + Gas_monad.run ctxt + @@ parse_views + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data} + ~elab_conf + ty + views + in + let*? views in + return (views, ctxt) let parse_code ~elab_conf ctxt ~code = parse_code ~unparse_code_rec ~elab_conf ctxt ~code @@ -6314,15 +6037,21 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ~elab_conf tc_context ctxt script_instr stack_ty -> - parse_instr - ~unparse_code_rec - ~parse_packable_data:{parse_packable_data} - ~elab_conf - ~stack_depth:0 - tc_context - ctxt - script_instr - stack_ty + let open Result_syntax in + Lwt.return + (let* i, ctxt = + Gas_monad.run ctxt + @@ parse_instr + ~unparse_code_rec + ~parse_packable_data:{parse_packable_data} + ~elab_conf + ~stack_depth:0 + tc_context + script_instr + stack_ty + in + let+ i in + (i, ctxt)) let parse_data ~elab_conf ctxt ~allow_forged ty t = parse_data ~unparse_code_rec ~elab_conf ~allow_forged ~stack_depth:0 ty t ctxt -- GitLab From 325fb015065daad7709097db618fa413f7b87d7e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 12:20:34 +0200 Subject: [PATCH 14/17] normalized_lam in gas monad --- .../lib_protocol/script_ir_translator.ml | 46 +++++++------------ 1 file changed, 16 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 6e05ee1b88c8..f9781d48655c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1934,19 +1934,16 @@ let parse_toplevel : Script.expr -> (toplevel, error trace) Gas_monad.t = (* Normalize lambdas during parsing *) let normalized_lam ~(unparse_code_rec : Script_ir_unparser.unparse_code_rec) - ~stack_depth ctxt kdescr code_field = - let open Lwt_result_syntax in - let elab_conf = Script_ir_translator_config.make ~legacy:true ctxt in - let*? code_field, ctxt = - Gas_monad.run ctxt - @@ unparse_code_rec - ~stack_depth:(stack_depth + 1) - ~elab_conf - Optimized - code_field + ~elab_conf ~stack_depth kdescr code_field = + let open Gas_monad.Syntax in + let+ code_field = + unparse_code_rec + ~stack_depth:(stack_depth + 1) + ~elab_conf + Optimized + code_field in - let*? code_field in - return (Lam (kdescr, code_field), ctxt) + Lam (kdescr, code_field) let normalized_lam_rec ~(unparse_code_rec : Script_ir_unparser.unparse_code_rec) ~elab_conf ~stack_depth kdescr code_field = @@ -4487,13 +4484,6 @@ module type GAS_MONAD = sig ('key -> 'value1 -> ('value2, error trace) t) -> ('key, 'value1) map -> (('key, 'value2) map, error trace) t - - val normalized_lam : - unparse_code_rec:unparse_code_rec -> - stack_depth:int -> - ('a, end_of_stack, 'b, end_of_stack) kdescr -> - Script.node -> - (('a, 'b) lambda, error trace) t end module GM : GAS_MONAD with type ('a, 'trace) t = ('a, 'trace) Gas_monad.t = @@ -4519,9 +4509,6 @@ struct let list_fold_left = Gas_monad.list_fold_left let map_map = Script_map.map_in_gas_monad - - let normalized_lam ~unparse_code_rec:_ ~stack_depth:_ _kdescr _script_instr = - assert false end module LGM : @@ -4592,9 +4579,6 @@ struct let map_map f m ctxt = Script_map.map_es_in_context (fun ctxt k v -> f k v ctxt) ctxt m - - let normalized_lam ~unparse_code_rec ~stack_depth kdescr script_instr ctxt = - normalized_lam ~unparse_code_rec ~stack_depth ctxt kdescr script_instr end module Data_parser (M : GAS_MONAD) = struct @@ -4920,11 +4904,13 @@ module Data_parser (M : GAS_MONAD) = struct tr script_instr in - (normalized_lam [@ocaml.tailcall]) - ~unparse_code_rec - ~stack_depth - kdescr - script_instr + from_gas_monad + @@ normalized_lam + ~unparse_code_rec + ~elab_conf + ~stack_depth:(stack_depth + 1) + kdescr + script_instr | ( Lambda_t (ta, tr, _ty_name), Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) -> traced -- GitLab From 3e7a05d83d61e28f405f6ef3a2c5ce8fe05c1b76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 13:30:53 +0200 Subject: [PATCH 15/17] Justify the `assert false`s --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f9781d48655c..8e7293e05f80 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4497,13 +4497,17 @@ struct let from_gas_monad g = g + (* Only used to parse the "contract" type, which is not packable *) 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 + (* Only used to parse the "sapling_state" type, which is not packable *) let sapling_state_from_id _id = assert false let list_fold_left = Gas_monad.list_fold_left -- GitLab From 23bf2f380975be20ec7f2f4e29d079f22fc41337 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 14:08:48 +0200 Subject: [PATCH 16/17] Export gas monad version of unparse_comparable_data --- .../lib_protocol/script_ir_translator.ml | 12 ++++++--- .../lib_protocol/script_ir_unparser.ml | 13 +++------- .../lib_protocol/script_ir_unparser.mli | 6 ++--- .../michelson/test_ticket_accounting.ml | 26 ++++++++++--------- .../test_ticket_lazy_storage_diff.ml | 13 +++++----- .../michelson/test_ticket_operations_diff.ml | 14 +++++----- .../lib_protocol/ticket_balance_key.ml | 13 +++++----- .../lib_protocol/ticket_token_unparser.ml | 6 +++-- 8 files changed, 54 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 8e7293e05f80..76e9c19b4cc1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -165,8 +165,11 @@ let pack_node unparsed ctxt = let pack_comparable_data ctxt ty data = let open Lwt_result_syntax in - let+ unparsed, ctxt = unparse_comparable_data ctxt Optimized_legacy ty data in - pack_node unparsed ctxt + let*? unparsed, ctxt = + Gas_monad.run ctxt @@ unparse_comparable_data Optimized_legacy ty data + in + let*? unparsed in + return (pack_node unparsed ctxt) let hash_bytes bytes = let open Gas_monad.Syntax in @@ -5605,7 +5608,10 @@ 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 = unparse_comparable_data ctxt mode key_type key 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) diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 4fba759a76f8..a329b9df4cd7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -821,12 +821,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct end end -let unparse_comparable_data ctxt mode ty v = - let open Lwt_result_syntax in - let*? unparsed_data, ctxt = - Gas_monad.run ctxt @@ unparse_comparable_data_rec ~loc:() mode ty v - in - let*? unparsed_data in - Lwt.return - (Gas_monad.run_pure ctxt - @@ account_for_future_serialization_cost unparsed_data) +let unparse_comparable_data mode ty v = + let open Gas_monad.Syntax in + let* unparsed_data = unparse_comparable_data_rec ~loc:() mode ty v in + account_for_future_serialization_cost unparsed_data diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 1490582750ab..ca2537ddac56 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -112,14 +112,12 @@ val unparse_with_data_encoding : ('loc Script.michelson_node, 'trace) Gas_monad.t (** [unparse_comparable_data ctxt unparsing_mode ty v] returns the - Micheline representation of [v] of type [ty], consuming gas from - [ctxt]. *) + Micheline representation of [v] of type [ty], consuming gas. *) val unparse_comparable_data : - context -> unparsing_mode -> 'a comparable_ty -> 'a -> - (Script.expr * context) tzresult Lwt.t + (Script.expr, error trace) Gas_monad.t (** [unparse_contract ~loc unparsin_mode contract] returns a Micheline representation of a given contract in a given [unparsing_mode], and consumes 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 4e3a020c40e1..f44d6aa9405c 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 @@ -52,13 +52,14 @@ let string_list_of_ex_token_diffs ctxt token_diffs = let open Lwt_result_wrap_syntax in let accum (xs, ctxt) (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let*@ x, ctxt = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - contents_type - contents + let*?@ x, ctxt = + Gas_monad.run ctxt + @@ Script_ir_unparser.unparse_comparable_data + Script_ir_unparser.Readable + contents_type + contents in + let*?@ x in let str = Format.asprintf {|{ticketer: "%a"; contents: %a; amount: %a}|} @@ -143,13 +144,14 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = let*@ key_hash, ctxt = Script_ir_translator.hash_comparable_data ctxt key_type key in - let*@ key, ctxt = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - key_type - key + let*?@ key, ctxt = + Gas_monad.run ctxt + @@ Script_ir_unparser.unparse_comparable_data + Script_ir_unparser.Readable + key_type + key in + let*?@ 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 fbdaea7a2bf7..08b3847c6a67 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 @@ -42,13 +42,14 @@ let string_list_of_ex_token_diffs ctxt token_diffs = let open Lwt_result_wrap_syntax in let accum (xs, ctxt) (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = - let*@ x, ctxt = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - contents_type - contents + let*?@ x, ctxt = + Gas_monad.run ctxt + @@ Script_ir_unparser.unparse_comparable_data + Script_ir_unparser.Readable + contents_type + contents in + let*?@ x in let str = Format.asprintf "((%a, %a), %a)" 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 5a59c1b4822a..33a108303513 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 @@ -116,15 +116,15 @@ let new_int_key_big_map ctxt contract ~value_type entries = let assert_equal_string_list ~loc msg = Assert.assert_equal_list ~loc String.equal msg Format.pp_print_string -let string_of_ticket_token ctxt +let string_of_ticket_token _ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) = let open Lwt_result_wrap_syntax in - let*@ x, _ = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Readable - contents_type - contents + let*?@ x = + Gas_monad.run_unaccounted + @@ Script_ir_unparser.unparse_comparable_data + Script_ir_unparser.Readable + contents_type + contents in return @@ Format.asprintf diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index 170e4136851a..ab41b37c8b5e 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -77,13 +77,14 @@ let of_ex_token ctxt ~owner Gas.consume ctxt (Script.strip_annotations_cost cont_ty_unstripped) in let ty = Script.strip_annotations cont_ty_unstripped in - let* contents, ctxt = - Script_ir_unparser.unparse_comparable_data - ctxt - Script_ir_unparser.Optimized_legacy - contents_type - contents + let*? contents, ctxt = + Gas_monad.run ctxt + @@ Script_ir_unparser.unparse_comparable_data + Script_ir_unparser.Optimized_legacy + contents_type + contents in + let*? contents in make ctxt ~owner diff --git a/src/proto_alpha/lib_protocol/ticket_token_unparser.ml b/src/proto_alpha/lib_protocol/ticket_token_unparser.ml index a993dce3c228..d88abf419bcc 100644 --- a/src/proto_alpha/lib_protocol/ticket_token_unparser.ml +++ b/src/proto_alpha/lib_protocol/ticket_token_unparser.ml @@ -37,9 +37,11 @@ open Alpha_context let unparse ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) = let open Lwt_result_syntax in let open Script_ir_unparser in - let* contents, ctxt = - unparse_comparable_data ctxt Optimized_legacy contents_type contents + let*? contents, ctxt = + Gas_monad.run ctxt + @@ unparse_comparable_data Optimized_legacy contents_type contents in + let*? contents in let*? ty_unstripped, ctxt = Gas_monad.run_pure ctxt @@ unparse_ty ~loc:Micheline.dummy_location contents_type -- GitLab From 684fbb7820d409051c3f1194a325ed62e2fbcd8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 20 Sep 2023 14:17:27 +0200 Subject: [PATCH 17/17] simplify test_ticket_operations_diff --- .../michelson/test_ticket_operations_diff.ml | 129 ++++++++---------- 1 file changed, 60 insertions(+), 69 deletions(-) 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 33a108303513..56bacc5f3198 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 @@ -116,7 +116,7 @@ let new_int_key_big_map ctxt contract ~value_type entries = let assert_equal_string_list ~loc msg = Assert.assert_equal_list ~loc String.equal msg Format.pp_print_string -let string_of_ticket_token _ctxt +let string_of_ticket_token (Ticket_token.Ex_token {ticketer; contents_type; contents}) = let open Lwt_result_wrap_syntax in let*?@ x = @@ -148,10 +148,10 @@ let string_of_destination_and_amounts cas = Script_int.(to_string (amount :> n num)))) cas -let string_of_ticket_operations_diff ctxt - {ticket_token; total_amount; destinations} = - let open Lwt_result_wrap_syntax in - let* ticket_token = string_of_ticket_token ctxt ticket_token in +let string_of_ticket_operations_diff {ticket_token; total_amount; destinations} + = + let open Lwt_result_syntax in + let* ticket_token = string_of_ticket_token ticket_token in let destinations = string_of_destination_and_amounts destinations in return (Printf.sprintf @@ -160,9 +160,9 @@ let string_of_ticket_operations_diff ctxt (Script_int.to_string total_amount) destinations) -let assert_equal_ticket_token_diffs ctxt ~loc ticket_diffs +let assert_equal_ticket_token_diffs ~loc ticket_diffs ~(expected : ticket_token_diff list) = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in (* Sort destinations by contract and the strings alphabetically so that order does not matter for comparison. *) let sorted_strings ticket_diffs = @@ -179,9 +179,7 @@ let assert_equal_ticket_token_diffs ctxt ~loc ticket_diffs }) ticket_diffs in - let+ strings = - List.map_es (string_of_ticket_operations_diff ctxt) ticket_diffs - in + let+ strings = List.map_es string_of_ticket_operations_diff ticket_diffs in List.sort String.compare strings in let* exp_str_diffs = sorted_strings expected in @@ -204,13 +202,13 @@ let string_token ~ticketer content = (** Initializes one address for operations and one baker. *) let init () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let+ block, (src0, src1) = Context.init2 ~consensus_threshold:0 () in let baker = Context.Contract.pkh src0 in (baker, src1, block) let originate block ~script ~storage ~sender ~baker ~forges_tickets = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let code = Expr.toplevel_from_string script in let storage = Expr.from_string storage in let* operation, destination = @@ -238,14 +236,14 @@ let originate block ~script ~storage ~sender ~baker ~forges_tickets = (destination, script, block) let two_ticketers block = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* result = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt result in let*! cs = Contract.list ctxt in match cs with c1 :: c2 :: _ -> return (c1, c2) | _ -> assert false let one_ticketer block = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let+ c1, _c2 = two_ticketers block in c1 @@ -309,7 +307,7 @@ let delegation_operation ~sender = {sender; operation = Delegation None; nonce = 1} let originate block ~sender ~baker ~script ~storage ~forges_tickets = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* orig_contract, _script, block = originate block ~script ~storage ~sender ~baker ~forges_tickets in @@ -349,9 +347,13 @@ let transfer_operation ~incr ~sender ~destination ~parameters_ty ~parameters = incr ) let ticket_diffs_of_operations incr operations = - Ticket_operations_diff.ticket_diffs_of_operations - (Incremental.alpha_ctxt incr) - operations + let open Lwt_result_wrap_syntax in + let+@ diff, _ctxt = + Ticket_operations_diff.ticket_diffs_of_operations + (Incremental.alpha_ctxt incr) + operations + in + diff let unit_script = {| @@ -393,7 +395,7 @@ let make_ticket (ticketer, contents, amount) = return {ticketer; contents; amount} let make_tickets ts = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* elements = List.map_es make_ticket ts in return @@ Script_list.of_list elements @@ -406,16 +408,16 @@ let transfer_tickets_operation ~incr ~sender ~destination tickets = (** Test that no tickets are returned for operations that do not contain tickets. *) let test_non_ticket_operations () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* _baker, sender, block = init () in let* incr = Incremental.begin_construction block in let operations = [delegation_operation ~sender:(Contract sender)] in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr operations in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] + let* ticket_diffs = ticket_diffs_of_operations incr operations in + assert_equal_ticket_token_diffs ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer to a contract that does not take tickets. *) let test_transfer_to_non_ticket_contract () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* orig_contract, incr = originate @@ -434,12 +436,12 @@ let test_transfer_to_non_ticket_contract () = ~parameters_ty:unit_t ~parameters:() in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in + assert_equal_ticket_token_diffs ~loc:__LOC__ ticket_diffs ~expected:[] (** Test transfer an empty list of tickets. *) let test_transfer_empty_ticket_list () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* orig_contract, incr = originate @@ -457,8 +459,8 @@ let test_transfer_empty_ticket_list () = ~destination:orig_contract [] in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in + assert_equal_ticket_token_diffs ~loc:__LOC__ ticket_diffs ~expected:[] let one = Ticket_amount.one @@ -470,7 +472,7 @@ let five = Ticket_amount.add three two (** Test transfer a list of one ticket. *) let test_transfer_one_ticket () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let* orig_contract, incr = @@ -489,9 +491,8 @@ let test_transfer_one_ticket () = ~destination:orig_contract [(ticketer, "white", 1)] in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -508,7 +509,7 @@ let test_transfer_one_ticket () = zero-tickets are disabled as well as when the parameters do not contain any zero-amount tickets. *) let test_transfer_multiple_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let* orig_contract, incr = @@ -533,9 +534,8 @@ let test_transfer_multiple_tickets () = ] in let orig_contract = Contract.Originated orig_contract in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -559,7 +559,7 @@ let test_transfer_multiple_tickets () = (** Test transfer a list of tickets of different types. *) let test_transfer_different_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer1, ticketer2 = two_ticketers block in let* destination, incr = @@ -589,9 +589,8 @@ let test_transfer_different_tickets () = ] in let destination = Destination.Contract (Originated destination) in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -630,7 +629,7 @@ let test_transfer_different_tickets () = (** Test transfer to two contracts with different types of tickets. *) let test_transfer_to_two_contracts_with_different_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let parameters = @@ -669,12 +668,11 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~destination:destination2 parameters in - let*@ ticket_diffs, ctxt = + let* ticket_diffs = ticket_diffs_of_operations incr [operation1; operation2] in let one = Ticket_amount.one in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -710,7 +708,7 @@ let test_transfer_to_two_contracts_with_different_tickets () = (** Test originate a contract that does not contain tickets. *) let test_originate_non_ticket_contract () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* _orig_contract, operation, incr = origination_operation @@ -721,12 +719,12 @@ let test_originate_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in + assert_equal_ticket_token_diffs ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with an empty list of tickets. *) let test_originate_with_empty_tickets_list () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let storage = "{}" in let* _orig_contract, operation, incr = @@ -738,12 +736,12 @@ let test_originate_with_empty_tickets_list () = ~storage ~forges_tickets:false in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in - assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in + assert_equal_ticket_token_diffs ~loc:__LOC__ ticket_diffs ~expected:[] (** Test originate a contract with a single ticket. *) let test_originate_with_one_ticket () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let storage = @@ -758,9 +756,8 @@ let test_originate_with_one_ticket () = ~storage ~forges_tickets:true in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -774,7 +771,7 @@ let test_originate_with_one_ticket () = (** Test originate a contract with multiple tickets. *) let test_originate_with_multiple_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let storage = @@ -800,9 +797,8 @@ let test_originate_with_multiple_tickets () = ~storage ~forges_tickets:true in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -826,7 +822,7 @@ let test_originate_with_multiple_tickets () = (** Test originate a contract with multiple tickets of different types. *) let test_originate_with_different_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer1, ticketer2 = two_ticketers block in let storage = @@ -863,9 +859,8 @@ let test_originate_with_different_tickets () = ~storage ~forges_tickets:true in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations ctxt [operation] in + let* ticket_diffs = ticket_diffs_of_operations ctxt [operation] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -904,7 +899,7 @@ let test_originate_with_different_tickets () = (** Test originate two contracts with multiple tickets of different types. *) let test_originate_two_contracts_with_different_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let storage = @@ -934,11 +929,10 @@ let test_originate_two_contracts_with_different_tickets () = ~storage ~forges_tickets:true in - let*@ ticket_diffs, ctxt = + let* ticket_diffs = ticket_diffs_of_operations incr [operation1; operations2] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -974,7 +968,7 @@ let test_originate_two_contracts_with_different_tickets () = (** Test originate and transfer tickets. *) let test_originate_and_transfer () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let ticketer_addr = Contract.to_b58check ticketer in @@ -1011,11 +1005,10 @@ let test_originate_and_transfer () = ~destination:destination2 [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] in - let*@ ticket_diffs, ctxt = + let* ticket_diffs = ticket_diffs_of_operations incr [operation1; operation2] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -1051,7 +1044,7 @@ let test_originate_and_transfer () = (** Test originate a contract with a big-map with tickets inside. *) let test_originate_big_map_with_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, ticketer, block = init () in let* operation, originated = Op.contract_origination_hash (B block) ticketer ~script:Op.dummy_script @@ -1084,9 +1077,8 @@ let test_originate_big_map_with_tickets () = ~storage ~forges_tickets:true in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -1110,7 +1102,7 @@ let test_originate_big_map_with_tickets () = (** Test transfer a big-map with tickets. *) let test_transfer_big_map_with_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, ticketer_contract, block = init () in let* operation, originated = Op.contract_origination_hash @@ -1168,10 +1160,9 @@ let test_transfer_big_map_with_tickets () = ~parameters_ty ~parameters in - let*@ ticket_diffs, ctxt = ticket_diffs_of_operations incr [operation] in + let* ticket_diffs = ticket_diffs_of_operations incr [operation] in let destination = Destination.Contract (Originated orig_contract) in assert_equal_ticket_token_diffs - ctxt ~loc:__LOC__ ticket_diffs ~expected: @@ -1196,7 +1187,7 @@ let test_transfer_big_map_with_tickets () = (** Test transferring a list of multiple tickets where two of them have zero amounts fails. *) let test_transfer_fails_on_multiple_zero_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let* orig_contract, incr = @@ -1226,7 +1217,7 @@ let test_transfer_fails_on_multiple_zero_tickets () = (** Test that zero-amount tickets are detected and that an error is yielded. *) let test_fail_on_zero_amount_tickets () = - let open Lwt_result_wrap_syntax in + let open Lwt_result_syntax in let* baker, sender, block = init () in let* ticketer = one_ticketer block in let storage = -- GitLab