From 4cad7e0ba82d319e25c4b634b93ca5ceb898a7d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:02:56 +0200 Subject: [PATCH 01/16] Revert "Proto/Michelson: regroup gas monad computations" This reverts commit e26f865dcb30241e4eafe61add875932676f15c6. --- .../lib_protocol/script_ir_translator.ml | 233 ++++++++---------- 1 file changed, 107 insertions(+), 126 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 05e977e164f8..ce3871732cb3 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2423,27 +2423,28 @@ and parse_view : {input_ty; output_ty; view_code} -> let legacy = elab_conf.legacy in let input_ty_loc = location input_ty in + let*? res, ctxt = + Gas_monad.run ctxt @@ parse_view_input_ty ~stack_depth:0 ~legacy input_ty + in + let*? (Ex_ty input_ty) = + record_trace_eval + (fun () -> + Ill_formed_type + (Some "arg of view", strip_locations input_ty, input_ty_loc)) + res + 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) + @@ parse_view_output_ty ~stack_depth:0 ~legacy output_ty + in + let*? (Ex_ty output_ty) = + record_trace_eval + (fun () -> + Ill_formed_type + (Some "return of view", strip_locations output_ty, output_ty_loc)) + res 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 = parse_instr @@ -3247,15 +3248,16 @@ and parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> - let*? res, ctxt = + let*? tk, 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) + @@ parse_comparable_ty ~stack_depth:(stack_depth + 1) tk in - let*? Ex_comparable_ty tk, Ex_ty tv = res in + let*? (Ex_comparable_ty tk) = tk in + let*? tv, ctxt = + Gas_monad.run ctxt + @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tv + in + let*? (Ex_ty tv) = tv in let*? () = check_var_type_annot loc annot in let instr = {apply = (fun k -> IEmpty_map (loc, tk, for_logging_only tv, k))} @@ -3370,17 +3372,16 @@ and parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> - let*? res, ctxt = + let*? tk, 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) + @@ parse_comparable_ty ~stack_depth:(stack_depth + 1) tk in - let*? Ex_comparable_ty tk, Ex_ty tv = res in + let*? (Ex_comparable_ty tk) = tk in + let*? tv, ctxt = + Gas_monad.run ctxt + @@ parse_big_map_value_ty ~stack_depth:(stack_depth + 1) ~legacy tv + in + let*? (Ex_ty tv) = tv 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 @@ -3598,15 +3599,16 @@ and parse_instr : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> - let*? res, ctxt = + let*? arg, ctxt = + Gas_monad.run ctxt + @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg + in + let*? (Ex_ty arg) = arg in + let*? ret, 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) + @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret in - let*? Ex_ty arg, Ex_ty ret = res in + let*? (Ex_ty ret) = ret in let*? () = check_kind [Seq_kind] code in let*? () = check_var_annot loc annot in let* kdescr, ctxt = @@ -3628,19 +3630,16 @@ and parse_instr : typed ctxt loc instr stack | ( Prim (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; lambda_expr], annot), stack ) -> - let*? res, ctxt = + let*? arg, 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) + @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr in - let*? Ex_ty arg, Ex_ty ret = res in + let*? (Ex_ty arg) = arg in + let*? ret, ctxt = + Gas_monad.run ctxt + @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr + in + let*? (Ex_ty ret) = ret 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 @@ -4114,17 +4113,15 @@ and parse_instr : (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> let*? () = check_var_annot loc annot in - let*? res, ctxt = + let*? cast_t, 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 - () + @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy cast_t in - let*? () = res in + let*? (Ex_ty cast_t) = cast_t in + let*? eq, ctxt = + Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t + in + let*? Eq = eq 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) @@ -4233,34 +4230,27 @@ and parse_instr : let*? {arg_type; storage_type; code_field; views}, ctxt = parse_toplevel ctxt canonical_code in + let*? arg_type_with_entrypoints, ctxt = + Gas_monad.run ctxt + @@ parse_parameter_ty_and_entrypoints + ~stack_depth:(stack_depth + 1) + ~legacy + arg_type + in + let*? (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = + record_trace + (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) + arg_type_with_entrypoints + in let*? res, ctxt = Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax 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) + @@ parse_storage_ty ~stack_depth:(stack_depth + 1) ~legacy storage_type in - let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = - res + let*? (Ex_ty storage_type) = + record_trace + (Ill_formed_type + (Some "storage", canonical_code, location storage_type)) + res in let*? (Ty_ex_c arg_type_full) = pair_t loc arg_type storage_type in let*? (Ty_ex_c ret_type_full) = @@ -5047,26 +5037,21 @@ let parse_code : parse_toplevel ctxt code in let arg_type_loc = location arg_type in - let storage_type_loc = location storage_type in let*? res, ctxt = Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* arg_type = - Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> - Ill_formed_type (Some "parameter", code, arg_type_loc)) - @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type - in - let+ storage_type = - Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> - Ill_formed_type (Some "storage", code, storage_type_loc)) - @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type - in - (arg_type, storage_type) + @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type + in + let*? (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = + record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) res in - let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = - res + let storage_type_loc = location storage_type in + let*? storage_type, ctxt = + Gas_monad.run ctxt @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type + in + let*? (Ex_ty storage_type) = + record_trace + (Ill_formed_type (Some "storage", code, storage_type_loc)) + storage_type in let*? (Ty_ex_c arg_type_full) = pair_t storage_type_loc arg_type storage_type @@ -5186,26 +5171,23 @@ let typecheck_code : let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in - let storage_type_loc = location storage_type in - let*? res, ctxt = + let*? arg_type, ctxt = Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* arg_type = - Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> - Ill_formed_type (Some "parameter", code, arg_type_loc)) - @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type - in - let+ ex_storage_type = - Gas_monad.record_trace_eval ~error_details:(Informative ()) (fun () -> - Ill_formed_type (Some "storage", code, storage_type_loc)) - @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type - in - (arg_type, ex_storage_type) + @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type + in + let*? (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = + record_trace + (Ill_formed_type (Some "parameter", code, arg_type_loc)) + arg_type in - let*? ( Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, - Ex_ty storage_type ) = - res + let storage_type_loc = location storage_type in + let*? ex_storage_type, ctxt = + Gas_monad.run ctxt @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type + in + let*? (Ex_ty storage_type) = + record_trace + (Ill_formed_type (Some "storage", code, storage_type_loc)) + ex_storage_type in let*? (Ty_ex_c arg_type_full) = pair_t storage_type_loc arg_type storage_type @@ -5353,13 +5335,12 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage let loc = Micheline.dummy_location in let* arg_type, storage_type, views, ctxt = if normalize_types then - let*? (arg_type, storage_type), ctxt = + let*? arg_type, ctxt = Gas_monad.run_pure ctxt - @@ - let open Gas_monad.Syntax in - let* arg_type = unparse_parameter_ty ~loc arg_type ~entrypoints in - let+ storage_type = unparse_ty ~loc storage_type in - (arg_type, storage_type) + @@ unparse_parameter_ty ~loc arg_type ~entrypoints + in + let*? storage_type, ctxt = + Gas_monad.run_pure ctxt @@ unparse_ty ~loc storage_type in let+ views, ctxt = Script_map.map_es_in_context -- GitLab From 0420f551cf808f98ee0d0f112d30da8351b46db8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:10:45 +0200 Subject: [PATCH 02/16] Revert "Doc/alpha changelog: mention !10071" This reverts commit 1b8be090530337231359baf6d94bdf9361664353. --- docs/protocols/alpha.rst | 2 -- 1 file changed, 2 deletions(-) diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index 1074703f8c6d..df83273d9529 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -73,5 +73,3 @@ Internal - Register an error's encoding: ``WASM_proof_verification_failed``. It was previously not registered, making the error message a bit obscure. (MR :gl:`!9603`) -- Move some Michelson elaboration and erasure functions to the gas - monad. (MR :gl:`!10071`) -- GitLab From 50bf3e82343f0b39db7ba6c8c529af0fb8bd01db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:10:53 +0200 Subject: [PATCH 03/16] Revert "Proto/Michelson: use let+$ and let*$ instead of consume_gas" This reverts commit c4626ed584c28e31b2d20c162c817e00e140b168. --- .../lib_protocol/script_ir_translator.ml | 16 +++++---- .../lib_protocol/script_ir_unparser.ml | 36 +++++++++---------- .../lib_protocol/test/unit/test_gas_monad.ml | 26 +++++++------- 3 files changed, 40 insertions(+), 38 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ce3871732cb3..0a39c30a3d99 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -170,7 +170,9 @@ let pack_comparable_data ctxt ty data = let hash_bytes bytes = let open Gas_monad.Syntax in - let+$ () = Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes in + let+ () = + Gas_monad.consume_gas (Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes) + in Script_expr_hash.(hash_bytes [bytes]) let hash_comparable_data ctxt ty data = @@ -195,7 +197,7 @@ let check_dupable_ty ctxt loc ty = let rec aux : type a ac. location -> (a, ac) ty -> (unit, error) Gas_monad.t = fun loc ty -> let open Gas_monad.Syntax in - let*$ () = Typecheck_costs.check_dupable_cycle in + let* () = Gas_monad.consume_gas Typecheck_costs.check_dupable_cycle in match ty with | Unit_t -> return_unit | Int_t -> return_unit @@ -442,7 +444,7 @@ let ty_eq : | Chest_key_t, _ -> not_equal () in let open Gas_monad.Syntax in - let*$ () = Typecheck_costs.ty_eq ty1 ty2 in + let* () = Gas_monad.consume_gas (Typecheck_costs.ty_eq ty1 ty2) in Gas_monad.of_result @@ help ty1 ty2 (* Same as ty_eq but for stacks. @@ -572,7 +574,7 @@ let rec parse_ty : ~allow_ticket ~ret node -> - let*$ () = Typecheck_costs.parse_type_cycle in + let* () = Gas_monad.consume_gas Typecheck_costs.parse_type_cycle in if Compare.Int.(stack_depth > 10000) then tzfail Typechecking_too_many_recursive_calls else @@ -980,7 +982,7 @@ and parse_any_ty : and parse_big_map_ty ~stack_depth ~legacy big_map_loc args map_annot = let open Gas_monad.Syntax in - let*$ () = Typecheck_costs.parse_type_cycle in + let* () = Gas_monad.consume_gas Typecheck_costs.parse_type_cycle in match args with | [key_ty; value_ty] -> let*? () = check_type_annot big_map_loc map_annot in @@ -1261,7 +1263,7 @@ let find_entrypoint (type full fullc error_context error_trace) Entrypoint.t -> (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> - let*$ () = Typecheck_costs.find_entrypoint_cycle in + let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in match (ty, entrypoints) with | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> @@ -4850,7 +4852,7 @@ and parse_contract : or (ticket cty). *) let typecheck = let open Gas_monad.Syntax in - let*$ () = Typecheck_costs.ty_eq_prim in + let* () = Gas_monad.consume_gas Typecheck_costs.ty_eq_prim in match arg with | Unit_t -> return (Typed_implicit destination : arg typed_contract) diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 1e0105efd4c7..7500eb26480d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -156,12 +156,12 @@ let unparse_ty_uncarbonated ~loc ty = let unparse_ty ~loc ty = let open Gas_monad.Syntax in - let+$ () = Unparse_costs.unparse_type ty in + let+ () = Gas_monad.consume_gas (Unparse_costs.unparse_type ty) in unparse_ty_uncarbonated ~loc ty let unparse_parameter_ty ~loc ty ~entrypoints = let open Gas_monad.Syntax in - let+$ () = Unparse_costs.unparse_type ty in + let+ () = Gas_monad.consume_gas (Unparse_costs.unparse_type ty) in unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root let serialize_ty_for_error ty = @@ -207,7 +207,7 @@ let unparse_timestamp ~loc mode t = | Optimized | Optimized_legacy -> return (Int (loc, Script_timestamp.to_zint t)) | Readable -> ( - let+$ () = Unparse_costs.timestamp_readable in + let+ () = Gas_monad.consume_gas Unparse_costs.timestamp_readable in match Script_timestamp.to_notation t with | None -> Int (loc, Script_timestamp.to_zint t) | Some s -> String (loc, s)) @@ -216,7 +216,7 @@ let unparse_address ~loc mode {destination; entrypoint} = let open Gas_monad.Syntax in match mode with | Optimized | Optimized_legacy -> - let+$ () = Unparse_costs.contract_optimized in + let+ () = Gas_monad.consume_gas Unparse_costs.contract_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding) @@ -224,7 +224,7 @@ let unparse_address ~loc mode {destination; entrypoint} = in Bytes (loc, bytes) | Readable -> - let+$ () = Unparse_costs.contract_readable in + let+ () = Gas_monad.consume_gas Unparse_costs.contract_readable in let notation = Destination.to_b58check destination ^ Entrypoint.to_address_suffix entrypoint @@ -242,11 +242,11 @@ let unparse_signature ~loc mode s = let s = Script_signature.get s in match mode with | Optimized | Optimized_legacy -> - let+$ () = Unparse_costs.signature_optimized in + let+ () = Gas_monad.consume_gas Unparse_costs.signature_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in Bytes (loc, bytes) | Readable -> - let+$ () = Unparse_costs.signature_readable in + let+ () = Gas_monad.consume_gas Unparse_costs.signature_readable in String (loc, Signature.to_b58check s) let unparse_mutez ~loc v = @@ -256,26 +256,26 @@ let unparse_key ~loc mode k = let open Gas_monad.Syntax in match mode with | Optimized | Optimized_legacy -> - let+$ () = Unparse_costs.public_key_optimized in + let+ () = Gas_monad.consume_gas Unparse_costs.public_key_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in Bytes (loc, bytes) | Readable -> - let+$ () = Unparse_costs.public_key_readable in + let+ () = Gas_monad.consume_gas Unparse_costs.public_key_readable in String (loc, Signature.Public_key.to_b58check k) let unparse_key_hash ~loc mode k = let open Gas_monad.Syntax in match mode with | Optimized | Optimized_legacy -> - let+$ () = Unparse_costs.key_hash_optimized in + let+ () = Gas_monad.consume_gas Unparse_costs.key_hash_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in Bytes (loc, bytes) | Readable -> - let+$ () = Unparse_costs.key_hash_readable in + let+ () = Gas_monad.consume_gas Unparse_costs.key_hash_readable in String (loc, Signature.Public_key_hash.to_b58check k) (* Operations are only unparsed during the production of execution traces of @@ -288,43 +288,43 @@ let unparse_operation ~loc {piop; lazy_storage_diff = _} = Apply_internal_results.internal_operation_encoding iop in - let+$ () = Unparse_costs.operation bytes in + let+ () = Gas_monad.consume_gas (Unparse_costs.operation bytes) in Bytes (loc, bytes) let unparse_chain_id ~loc mode chain_id = let open Gas_monad.Syntax in match mode with | Optimized | Optimized_legacy -> - let+$ () = Unparse_costs.chain_id_optimized in + let+ () = Gas_monad.consume_gas Unparse_costs.chain_id_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id in Bytes (loc, bytes) | Readable -> - let+$ () = Unparse_costs.chain_id_readable in + let+ () = Gas_monad.consume_gas Unparse_costs.chain_id_readable in String (loc, Script_chain_id.to_b58check chain_id) let unparse_bls12_381_g1 ~loc x = let open Gas_monad.Syntax in - let+$ () = Unparse_costs.bls12_381_g1 in + let+ () = Gas_monad.consume_gas Unparse_costs.bls12_381_g1 in let bytes = Script_bls.G1.to_bytes x in Bytes (loc, bytes) let unparse_bls12_381_g2 ~loc x = let open Gas_monad.Syntax in - let+$ () = Unparse_costs.bls12_381_g2 in + let+ () = Gas_monad.consume_gas Unparse_costs.bls12_381_g2 in let bytes = Script_bls.G2.to_bytes x in Bytes (loc, bytes) let unparse_bls12_381_fr ~loc x = let open Gas_monad.Syntax in - let+$ () = Unparse_costs.bls12_381_fr in + let+ () = Gas_monad.consume_gas Unparse_costs.bls12_381_fr in let bytes = Script_bls.Fr.to_bytes x in Bytes (loc, bytes) let unparse_with_data_encoding ~loc s unparse_cost encoding = let open Gas_monad.Syntax in - let+$ () = unparse_cost in + let+ () = Gas_monad.consume_gas unparse_cost in let bytes = Data_encoding.Binary.to_bytes_exn encoding s in Bytes (loc, bytes) diff --git a/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml b/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml index 0d71674fc4e7..10dfad53a59b 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml @@ -84,9 +84,9 @@ let test_gas_exhaustion () = with_context ~limit:ten_milligas @@ fun ctxt -> let gas_monad = let open Gas_monad.Syntax in - let*$ () = Saturation_repr.safe_int 5 in + let* () = GM.consume_gas (Saturation_repr.safe_int 5) in let* x = GM.return 1 in - let*$ () = Saturation_repr.safe_int 10 in + let* () = GM.consume_gas (Saturation_repr.safe_int 10) in let* y = GM.return 2 in GM.return (x + y) in @@ -98,9 +98,9 @@ let test_gas_exhaustion_before_error () = with_context ~limit:ten_milligas @@ fun ctxt -> let gas_monad = let open Gas_monad.Syntax in - let*$ () = Saturation_repr.safe_int 5 in + let* () = GM.consume_gas (Saturation_repr.safe_int 5) in let* x = GM.return 1 in - let*$ () = Saturation_repr.safe_int 10 in + let* () = GM.consume_gas (Saturation_repr.safe_int 10) in let* () = GM.of_result (Error "Oh no") in let* y = GM.return 2 in GM.return (x + y) @@ -113,9 +113,9 @@ let test_successful_with_remaining_gas () = let gas_monad = let open Gas_monad.Syntax in let* x = GM.return 1 in - let*$ () = Saturation_repr.safe_int 5 in + let* () = GM.consume_gas (Saturation_repr.safe_int 5) in let* y = GM.return 2 in - let*$ () = Saturation_repr.safe_int 5 in + let* () = GM.consume_gas (Saturation_repr.safe_int 5) in GM.return (x + y) in assert_success ~loc:__LOC__ ctxt gas_monad ~result:3 ~remaining_gas:0 @@ -127,9 +127,9 @@ let test_successful_with_spare_gas () = let gas_monad = let open Gas_monad.Syntax in let* x = GM.return 1 in - let*$ () = Saturation_repr.safe_int 5 in + let* () = GM.consume_gas (Saturation_repr.safe_int 5) in let* y = GM.return 2 in - let*$ () = Saturation_repr.safe_int 3 in + let* () = GM.consume_gas (Saturation_repr.safe_int 3) in GM.return (x + y) in assert_success ~loc:__LOC__ ctxt gas_monad ~result:3 ~remaining_gas:2 @@ -140,10 +140,10 @@ let test_inner_error () = let gas_monad = let open Gas_monad.Syntax in let* x = GM.return 1 in - let*$ () = Saturation_repr.safe_int 5 in + let* () = GM.consume_gas (Saturation_repr.safe_int 5) in let* () = GM.of_result (Error "Oh no") in let* y = GM.return 2 in - let*$ () = Saturation_repr.safe_int 10 in + let* () = GM.consume_gas (Saturation_repr.safe_int 10) in GM.return (x + y) in assert_inner_errors @@ -161,10 +161,10 @@ let test_unlimited () = let gas_monad = let open Gas_monad.Syntax in let* x = GM.return 1 in - let*$ () = Saturation_repr.safe_int 5 in + let* () = GM.consume_gas (Saturation_repr.safe_int 5) in let* y = GM.return 2 in - let*$ () = Saturation_repr.safe_int 100 in - let*$ () = Saturation_repr.safe_int 3 in + let* () = GM.consume_gas (Saturation_repr.safe_int 100) in + let* () = GM.consume_gas (Saturation_repr.safe_int 3) in GM.return (x + y) in assert_success -- GitLab From b3557431ab0aedfec76eef2bf56226c207a9c4ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:10:57 +0200 Subject: [PATCH 04/16] Revert "Proto/Gas monad: let*$ and let+$" This reverts commit 50e51273532d2228ca2bc30658bb74e275166475. --- src/proto_alpha/lib_protocol/gas_monad.ml | 4 ---- src/proto_alpha/lib_protocol/gas_monad.mli | 5 ----- 2 files changed, 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index eebad0580add..f7908a3637e0 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -151,8 +151,4 @@ module Syntax = struct let ( let*? ) = bind_result let ( let+? ) m f = map_result f m - - let ( let*$ ) cost f = bind (consume_gas cost) f - - let ( let+$ ) cost f = map f (consume_gas cost) end diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index 9ecd2d57494b..18a2e6cc6534 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -140,9 +140,4 @@ module Syntax : sig (** [let+?] is for mapping the value from result-only expressions into the gas-monad. *) val ( let+? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) t - - val ( let*$ ) : - Alpha_context.Gas.cost -> (unit -> ('a, 'trace) t) -> ('a, 'trace) t - - val ( let+$ ) : Alpha_context.Gas.cost -> (unit -> 'a) -> ('a, 'trace) t end -- GitLab From cfb106fdf0d041dfb9ced23edee9ae6ee1c79272 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:13:13 +0200 Subject: [PATCH 05/16] Revert "Proto/Michelson: put parsing funs for types in the gas monad" This reverts commit 9ea26326925df3282324f496203771511d2ba5f8. --- devtools/get_contracts/get_contracts_alpha.ml | 20 +- .../lib_benchmark/test/test_helpers.ml | 2 +- src/proto_alpha/lib_benchmark/type_helpers.ml | 32 +- .../lib_benchmark/type_helpers.mli | 9 +- .../script_typed_ir_size_benchmarks.ml | 4 +- .../translator_benchmarks.ml | 17 +- src/proto_alpha/lib_plugin/RPC.ml | 100 +-- .../lib_protocol/contract_services.ml | 61 +- .../sc_rollup_management_protocol.ml | 11 +- .../lib_protocol/sc_rollup_operations.ml | 24 +- .../lib_protocol/script_ir_translator.ml | 593 +++++++++--------- .../lib_protocol/script_ir_translator.mli | 45 +- .../lib_protocol/script_ir_unparser.ml | 16 +- .../lib_protocol/script_ir_unparser.mli | 3 +- .../michelson/test_ticket_accounting.ml | 5 +- .../michelson/test_ticket_balance_key.ml | 5 +- .../test_ticket_lazy_storage_diff.ml | 5 +- .../michelson/test_ticket_scanner.ml | 14 +- .../michelson/test_typechecking.ml | 41 +- .../operations/test_transfer_ticket.ml | 12 +- .../integration/operations/test_zk_rollup.ml | 5 +- .../lib_protocol/ticket_lazy_storage_diff.ml | 13 +- .../lib_protocol/ticket_transfer.ml | 6 +- .../lib_protocol/zk_rollup_apply.ml | 6 +- 24 files changed, 483 insertions(+), 566 deletions(-) diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 9c04ef4be89d..dea478dbd21f 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -110,18 +110,14 @@ module Proto = struct let ctxt : Alpha_context.context = Obj.magic raw_ctxt in let+ Script_typed_ir.Ex_ty ty, updated_ctxt = wrap_tzresult - @@ let* res, ctxt = - Gas_monad.run ctxt - @@ Script_ir_translator.parse_ty - ~legacy:true - ~allow_lazy_storage - ~allow_operation - ~allow_contract - ~allow_ticket - script - in - let+ res in - (res, ctxt) + @@ Script_ir_translator.parse_ty + ctxt + ~legacy:true + ~allow_lazy_storage + ~allow_operation + ~allow_contract + ~allow_ticket + script in let consumed = (Alpha_context.Gas.consumed ~since:ctxt ~until:updated_ctxt :> int) diff --git a/src/proto_alpha/lib_benchmark/test/test_helpers.ml b/src/proto_alpha/lib_benchmark/test/test_helpers.ml index 0f73aa711b06..8d5db86cc9ed 100644 --- a/src/proto_alpha/lib_benchmark/test/test_helpers.ml +++ b/src/proto_alpha/lib_benchmark/test/test_helpers.ml @@ -78,7 +78,7 @@ let typecheck_by_tezos = (Lwt_main.run ( context_init_memory ~rng_state >>=? fun ctxt -> let (Protocol.Script_ir_translator.Ex_stack_ty bef) = - Type_helpers.michelson_type_list_to_ex_stack_ty bef + Type_helpers.michelson_type_list_to_ex_stack_ty bef ctxt in Protocol.Script_ir_translator.parse_instr Protocol.Script_tc_context.data diff --git a/src/proto_alpha/lib_benchmark/type_helpers.ml b/src/proto_alpha/lib_benchmark/type_helpers.ml index 3691276d0c5a..989ee7782901 100644 --- a/src/proto_alpha/lib_benchmark/type_helpers.ml +++ b/src/proto_alpha/lib_benchmark/type_helpers.ml @@ -32,19 +32,19 @@ exception Type_helpers_error of string let helpers_error msg = raise (Type_helpers_error msg) (* Convert a Micheline-encoded type to its internal GADT format. *) -let michelson_type_to_ex_ty (typ : Alpha_context.Script.expr) = - let res = - Environment.wrap_tzresult @@ Gas_monad.run_unaccounted - @@ Script_ir_translator.parse_ty - ~legacy:false - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:false - ~allow_ticket:false - (Micheline.root typ) - in - match res with - | Ok ex_ty -> ex_ty +let michelson_type_to_ex_ty (typ : Alpha_context.Script.expr) + (ctxt : Alpha_context.t) = + Script_ir_translator.parse_ty + ctxt + ~legacy:false + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:false + ~allow_ticket:false + (Micheline.root typ) + |> Environment.wrap_tzresult + |> function + | Ok (ex_ty, _ctxt) -> ex_ty | Error errs -> let msg = Format.asprintf @@ -57,16 +57,16 @@ let michelson_type_to_ex_ty (typ : Alpha_context.Script.expr) = (* Convert a list of Micheline-encoded Michelson types to the internal GADT format. *) let rec michelson_type_list_to_ex_stack_ty - (stack_ty : Alpha_context.Script.expr list) = + (stack_ty : Alpha_context.Script.expr list) ctxt = let open Script_ir_translator in let open Script_typed_ir in match stack_ty with | [] -> Ex_stack_ty Bot_t | hd :: tl -> ( - let ex_ty = michelson_type_to_ex_ty hd in + let ex_ty = michelson_type_to_ex_ty hd ctxt in match ex_ty with | Ex_ty ty -> ( - let ex_stack_ty = michelson_type_list_to_ex_stack_ty tl in + let ex_stack_ty = michelson_type_list_to_ex_stack_ty tl ctxt in match ex_stack_ty with | Ex_stack_ty tl -> Ex_stack_ty (Item_t (ty, tl)))) diff --git a/src/proto_alpha/lib_benchmark/type_helpers.mli b/src/proto_alpha/lib_benchmark/type_helpers.mli index d9e9b11f19af..0cf310d3afcf 100644 --- a/src/proto_alpha/lib_benchmark/type_helpers.mli +++ b/src/proto_alpha/lib_benchmark/type_helpers.mli @@ -36,12 +36,15 @@ exception Type_helpers_error of string @raise Type_helpers_error if parsing the Michelson type fails. *) val michelson_type_list_to_ex_stack_ty : - Alpha_context.Script.expr list -> Script_ir_translator.ex_stack_ty + Alpha_context.Script.expr list -> + Alpha_context.t -> + Script_ir_translator.ex_stack_ty (** [michelson_type_to_ex_ty ty ctxt] parses the type [ty]. @raise Type_helpers_error if an error arises during parsing. *) -val michelson_type_to_ex_ty : Alpha_context.Script.expr -> Script_typed_ir.ex_ty +val michelson_type_to_ex_ty : + Alpha_context.Script.expr -> Alpha_context.t -> Script_typed_ir.ex_ty (** [stack_type_to_michelson_type_list] converts a Mikhailsky stack type to a stack represented as a list of Micheline expressions, each @@ -51,4 +54,4 @@ val michelson_type_to_ex_ty : Alpha_context.Script.expr -> Script_typed_ir.ex_ty val stack_type_to_michelson_type_list : Type.Stack.t -> Script_repr.expr list (** [base_type_to_ex_ty] converts a Mikhailsky type to a Michelson one. *) -val base_type_to_ex_ty : Type.Base.t -> Script_typed_ir.ex_ty +val base_type_to_ex_ty : Type.Base.t -> Alpha_context.t -> Script_typed_ir.ex_ty diff --git a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml index c8a63e224160..74e3e212b6fa 100644 --- a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml @@ -86,7 +86,7 @@ module Value_size_benchmark : Tezos_benchmark.Benchmark.S = struct let open Translator_benchmarks in Lwt_main.run (let* ctxt, _ = Execution_context.make ~rng_state () in - let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type in + let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in match ex_ty with | Script_typed_ir.Ex_ty ty -> ( match @@ -204,7 +204,7 @@ module Kinstr_size_benchmark : Tezos_benchmark.Benchmark.S = struct Lwt_main.run (let* ctxt, _ = Execution_context.make ~rng_state () in let ex_stack_ty = - Type_helpers.michelson_type_list_to_ex_stack_ty stack + Type_helpers.michelson_type_list_to_ex_stack_ty stack ctxt in let (Script_ir_translator.Ex_stack_ty bef) = ex_stack_ty in let node = Micheline.root expr in diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 3244f5dd882e..613bf75b3c76 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -213,7 +213,7 @@ module Typechecking_data : Benchmark.S = struct let open Lwt_result_syntax in Lwt_main.run (let* ctxt, _ = Execution_context.make ~rng_state () in - let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type in + let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in let workload = match Translator_workload.data_typechecker_workload @@ -293,7 +293,7 @@ module Unparsing_data : Benchmark.S = struct let open Lwt_result_syntax in Lwt_main.run (let* ctxt, _ = Execution_context.make ~rng_state () in - let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type in + let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in let workload = match Translator_workload.data_typechecker_workload @@ -384,7 +384,7 @@ module Typechecking_code : Benchmark.S = struct Lwt_main.run (let* ctxt, _ = Execution_context.make ~rng_state () in let ex_stack_ty = - Type_helpers.michelson_type_list_to_ex_stack_ty stack + Type_helpers.michelson_type_list_to_ex_stack_ty stack ctxt in let workload = match @@ -468,7 +468,7 @@ module Unparsing_code : Benchmark.S = struct Lwt_main.run (let* ctxt, _ = Execution_context.make ~rng_state () in let ex_stack_ty = - Type_helpers.michelson_type_list_to_ex_stack_ty stack + Type_helpers.michelson_type_list_to_ex_stack_ty stack ctxt in let workload = match @@ -724,8 +724,9 @@ module Parse_type_shared = struct let tags = [Tags.translator] end -let parse_ty node = +let parse_ty ctxt node = Script_ir_translator.parse_ty + ctxt ~legacy:true ~allow_lazy_storage:true ~allow_operation:true @@ -758,9 +759,7 @@ module Parse_type_benchmark : Benchmark.S = struct match ty with | Ex_ty ty -> let* unparsed, _ = Environment.wrap_tzresult @@ unparse_ty ctxt ty in - let* _, ctxt' = - Environment.wrap_tzresult @@ Gas_monad.run ctxt @@ parse_ty unparsed - in + let* _, ctxt' = Environment.wrap_tzresult @@ parse_ty ctxt unparsed in let consumed = Z.to_int (Gas_helpers.fp_to_z @@ -771,7 +770,7 @@ module Parse_type_benchmark : Benchmark.S = struct Saturation_repr.to_int @@ Script_typed_ir.Type_size.to_int x in let workload = Type_workload {nodes; consumed} in - let closure () = ignore (Gas_monad.run ctxt @@ parse_ty unparsed) in + let closure () = ignore (parse_ty ctxt unparsed) in return (Generator.Plain {workload; closure})) |> function | Ok closure -> closure diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 8cfbba3c464c..af9fed1a9a48 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -691,15 +691,14 @@ module Scripts = struct context tzresult Lwt.t = let open Lwt_result_syntax in fun ~legacy ctxt (data, exp_ty) -> - let*? res, ctxt = + let*? Ex_ty exp_ty, ctxt = record_trace (Script_tc_errors.Ill_formed_type (None, exp_ty, 0)) - (Gas_monad.run ctxt - @@ Script_ir_translator.parse_passable_ty - ~legacy - (Micheline.root exp_ty)) + (Script_ir_translator.parse_passable_ty + ctxt + ~legacy + (Micheline.root exp_ty)) in - let*? (Ex_ty exp_ty) = res in let+ _, ctxt = trace_eval (fun () -> @@ -819,17 +818,16 @@ module Scripts = struct match l with | [] -> return (Ex_stack (Bot_t, EmptyCell, EmptyCell), ctxt) | (ty_node, data_node) :: l -> - let*? res, ctxt = - Gas_monad.run ctxt - @@ Script_ir_translator.parse_ty - ~legacy - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - ty_node + let*? Ex_ty ty, ctxt = + Script_ir_translator.parse_ty + ctxt + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + ty_node in - let*? (Ex_ty ty) = res in let elab_conf = elab_conf ~legacy () in let* x, ctxt = Script_ir_translator.parse_data @@ -1211,23 +1209,19 @@ module Scripts = struct let ctxt = Gas.set_unlimited ctxt in let legacy = false in let open Script_ir_translator in - let* {arg_type; _}, (_ctxt : context) = parse_toplevel ctxt expr in - let*? original_type_expr = - Gas_monad.run_unaccounted - @@ - let open Gas_monad.Syntax in - let* (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = - parse_parameter_ty_and_entrypoints ~legacy arg_type - in - let+ (Ex_ty_cstr {original_type_expr; _}) = - Script_ir_translator.find_entrypoint - ~error_details:(Informative ()) - arg_type - entrypoints - entrypoint - in - original_type_expr + let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ = + parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type in + let*? r, _ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.find_entrypoint + ~error_details:(Informative ()) + arg_type + entrypoints + entrypoint + in + let*? (Ex_ty_cstr {original_type_expr; _}) = r in return @@ Micheline.strip_locations original_type_expr in let script_view_type ctxt contract expr view = @@ -1676,11 +1670,9 @@ module Scripts = struct | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in - let*? res, ctxt = - Gas_monad.run ctxt - @@ parse_packable_ty ~legacy:true (Micheline.root typ) + let*? Ex_ty typ, ctxt = + parse_packable_ty ctxt ~legacy:true (Micheline.root typ) in - let*? (Ex_ty typ) = res in let* data, ctxt = parse_data ctxt @@ -1698,9 +1690,8 @@ module Scripts = struct let open Script_ir_translator in let legacy = Option.value ~default:false legacy in let ctxt = Gas.set_unlimited ctxt in - let*? (Ex_ty typ) = - Gas_monad.run_unaccounted - @@ Script_ir_translator.parse_any_ty ~legacy (Micheline.root typ) + let*? Ex_ty typ, ctxt = + Script_ir_translator.parse_any_ty ctxt ~legacy (Micheline.root typ) in let* data, ctxt = parse_data @@ -1742,11 +1733,19 @@ module Scripts = struct (Micheline.root script) in normalized) ; - Registration.register0 ~chunked:true S.normalize_type (fun _ctxt () typ -> + Registration.register0 ~chunked:true S.normalize_type (fun ctxt () typ -> let open Script_typed_ir in - let*? (Ex_ty typ) = - Gas_monad.run_unaccounted - @@ Script_ir_translator.parse_any_ty ~legacy:true (Micheline.root typ) + let ctxt = Gas.set_unlimited ctxt in + (* Unfortunately, Script_ir_translator.parse_any_ty is not exported *) + let*? Ex_ty typ, _ctxt = + Script_ir_translator.parse_ty + ctxt + ~legacy:true + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + (Micheline.root typ) in let normalized = Unparse_types.unparse_ty ~loc:() typ in return @@ Micheline.strip_locations normalized) ; @@ -1770,10 +1769,9 @@ module Scripts = struct let ctxt = Gas.set_unlimited ctxt in let legacy = false in let open Script_ir_translator in - let* {arg_type; _}, (_ctxt : context) = parse_toplevel ctxt expr in - let*? (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = - Gas_monad.run_unaccounted - @@ parse_parameter_ty_and_entrypoints ~legacy arg_type + let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ = + parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type in return @@ @@ -2231,9 +2229,11 @@ module Big_map = struct match types with | None -> raise Not_found | Some (_, value_type) -> ( - let*? (Ex_ty value_type) = - Gas_monad.run_unaccounted - @@ parse_big_map_value_ty ~legacy:true (Micheline.root value_type) + let*? Ex_ty value_type, ctxt = + parse_big_map_value_ty + ctxt + ~legacy:true + (Micheline.root value_type) in let* _ctxt, value = Big_map.get_opt ctxt id key in match value with diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 115979be4778..363002a8c6ed 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -410,9 +410,8 @@ let register () = match types with | None -> return_none | Some (_, value_type) -> ( - let*? (Ex_ty value_type) = - Gas_monad.run_unaccounted - @@ parse_big_map_value_ty ~legacy:true (Micheline.root value_type) + let*? Ex_ty value_type, ctxt = + parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type) in let* _ctxt, value = Big_map.get_opt ctxt id key in match value with @@ -436,9 +435,8 @@ let register () = match types with | None -> raise Not_found | Some (_, value_type) -> - let*? (Ex_ty value_type) = - Gas_monad.run_unaccounted - @@ parse_big_map_value_ty ~legacy:true (Micheline.root value_type) + let*? Ex_ty value_type, ctxt = + parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type) in let* ctxt, key_values = Big_map.list_key_values ?offset ?length ctxt id @@ -551,30 +549,28 @@ let register () = ctxt expr in - let* {arg_type; _}, (_ctxt : context) = - parse_toplevel ctxt expr + let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ = + parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type in - let r = - Gas_monad.run_unaccounted - (let open Gas_monad.Syntax in - let* (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) - = - parse_parameter_ty_and_entrypoints ~legacy arg_type - in - let* (Ex_ty_cstr {ty; original_type_expr; _}) = - Script_ir_translator.find_entrypoint - ~error_details:(Informative ()) - arg_type - entrypoints - entrypoint - in - if normalize_types then - let+ ty_node = Script_ir_unparser.unparse_ty ~loc:() ty in - Micheline.strip_locations ty_node - else return @@ Micheline.strip_locations original_type_expr) + let*? r, ctxt = + Gas_monad.run ctxt + @@ Script_ir_translator.find_entrypoint + ~error_details:(Informative ()) + arg_type + entrypoints + entrypoint in r |> function - | Ok node -> return_some node + | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> + if normalize_types then + let*? ty_node, _ctxt = + Gas_monad.run_pure ctxt + @@ Script_ir_unparser.unparse_ty ~loc:() ty + in + return_some (Micheline.strip_locations ty_node) + else + return_some (Micheline.strip_locations original_type_expr) | Error _ -> return_none))) ; opt_register1 ~chunked:true @@ -599,9 +595,9 @@ let register () = let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in Lwt.return (let open Result_syntax in - let* (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = - Gas_monad.run_unaccounted - @@ parse_parameter_ty_and_entrypoints ~legacy arg_type + let* Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ + = + parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type in let unreachable_entrypoint, map = Script_ir_translator.list_entrypoints_uncarbonated @@ -638,9 +634,8 @@ let register () = | Originated contract -> ( let* ctxt, script = Contract.get_script ctxt contract in let key_type_node = Micheline.root key_type in - let*? (Ex_comparable_ty key_type) = - Gas_monad.run_unaccounted - @@ Script_ir_translator.parse_comparable_ty key_type_node + let*? Ex_comparable_ty key_type, ctxt = + Script_ir_translator.parse_comparable_ty ctxt key_type_node in let* key, ctxt = Script_ir_translator.parse_comparable_data diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index a8082f48e8e0..3bd0d7b13667 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -120,13 +120,12 @@ let internal_typed_transaction ctxt Sc_rollup.Outbox.Message.typed_transaction) = let open Lwt_result_syntax in (* Parse the parameters type according to the type. *) - let*? res, ctxt = - Gas_monad.run ctxt - @@ Script_ir_translator.parse_any_ty - ~legacy:false - (Micheline.root unparsed_ty) + let*? Ex_ty parameters_ty, ctxt = + Script_ir_translator.parse_any_ty + ctxt + ~legacy:false + (Micheline.root unparsed_ty) in - let*? (Ex_ty parameters_ty) = res in make_transaction ctxt ~parameters_ty diff --git a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml index 891b89ebec1b..7a16f39dccc2 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml @@ -292,19 +292,17 @@ let validate_untyped_parameters_ty ctxt parameters_ty = [parse_parameter_ty_and_entrypoints] restricts to [passable] types (everything but operations), which is OK since [validate_ty] constraints the type further. *) - let* res, ctxt = - Gas_monad.run ctxt - @@ Script_ir_translator.parse_parameter_ty_and_entrypoints - ~legacy:false - (Micheline.root parameters_ty) - in - let* (Ex_parameter_ty_and_entrypoints - { - arg_type; - entrypoints = - {Script_typed_ir.root = entrypoint; original_type_expr = _}; - }) = - res + let* ( Ex_parameter_ty_and_entrypoints + { + arg_type; + entrypoints = + {Script_typed_ir.root = entrypoint; original_type_expr = _}; + }, + ctxt ) = + Script_ir_translator.parse_parameter_ty_and_entrypoints + ctxt + ~legacy:false + (Micheline.root parameters_ty) in (* TODO: https://gitlab.com/tezos/tezos/-/issues/4023 We currently don't support entrypoints as the entrypoint information diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 0a39c30a3d99..0b7acfd83017 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -556,6 +556,7 @@ type ('ret, 'name) parse_ty_ret = let rec parse_ty : type ret name. + context -> stack_depth:int -> legacy:bool -> allow_lazy_storage:bool -> @@ -564,9 +565,10 @@ let rec parse_ty : allow_ticket:bool -> ret:(ret, name) parse_ty_ret -> Script.node -> - (ret, error trace) Gas_monad.t = - let open Gas_monad.Syntax in - fun ~stack_depth + (ret * context) tzresult = + let open Result_syntax in + fun ctxt + ~stack_depth ~legacy ~allow_lazy_storage ~allow_operation @@ -574,110 +576,112 @@ let rec parse_ty : ~allow_ticket ~ret node -> - let* () = Gas_monad.consume_gas Typecheck_costs.parse_type_cycle in + let* ctxt = Gas.consume ctxt Typecheck_costs.parse_type_cycle in if Compare.Int.(stack_depth > 10000) then tzfail Typechecking_too_many_recursive_calls else let* node, name = match ret with | Don't_parse_entrypoints -> return (node, (() : name)) - | Parse_entrypoints -> - Gas_monad.of_result @@ extract_entrypoint_annot node + | Parse_entrypoints -> extract_entrypoint_annot node in - let return ty : ret = + let return ctxt ty : ret * context = match ret with - | Don't_parse_entrypoints -> Ex_ty ty + | Don't_parse_entrypoints -> (Ex_ty ty, ctxt) | Parse_entrypoints -> let at_node = Option.map (fun name -> {name; original_type_expr = node}) name in - Ex_parameter_ty_and_entrypoints_node - { - arg_type = ty; - entrypoints = {at_node; nested = Entrypoints_None}; - } + ( Ex_parameter_ty_and_entrypoints_node + { + arg_type = ty; + entrypoints = {at_node; nested = Entrypoints_None}; + }, + ctxt ) in match node with | Prim (loc, T_unit, [], annot) -> - let+? () = check_type_annot loc annot in - return unit_t + let+ () = check_type_annot loc annot in + return ctxt unit_t | Prim (loc, T_int, [], annot) -> - let+? () = check_type_annot loc annot in - return int_t + let+ () = check_type_annot loc annot in + return ctxt int_t | Prim (loc, T_nat, [], annot) -> - let+? () = check_type_annot loc annot in - return nat_t + let+ () = check_type_annot loc annot in + return ctxt nat_t | Prim (loc, T_string, [], annot) -> - let+? () = check_type_annot loc annot in - return string_t + let+ () = check_type_annot loc annot in + return ctxt string_t | Prim (loc, T_bytes, [], annot) -> - let+? () = check_type_annot loc annot in - return bytes_t + let+ () = check_type_annot loc annot in + return ctxt bytes_t | Prim (loc, T_mutez, [], annot) -> - let+? () = check_type_annot loc annot in - return mutez_t + let+ () = check_type_annot loc annot in + return ctxt mutez_t | Prim (loc, T_bool, [], annot) -> - let+? () = check_type_annot loc annot in - return bool_t + let+ () = check_type_annot loc annot in + return ctxt bool_t | Prim (loc, T_key, [], annot) -> - let+? () = check_type_annot loc annot in - return key_t + let+ () = check_type_annot loc annot in + return ctxt key_t | Prim (loc, T_key_hash, [], annot) -> - let+? () = check_type_annot loc annot in - return key_hash_t + let+ () = check_type_annot loc annot in + return ctxt key_hash_t | Prim (loc, T_chest_key, [], annot) -> - let+? () = check_type_annot loc annot in - return chest_key_t + let+ () = check_type_annot loc annot in + return ctxt chest_key_t | Prim (loc, T_chest, [], annot) -> - let+? () = check_type_annot loc annot in - return chest_t + let+ () = check_type_annot loc annot in + return ctxt chest_t | Prim (loc, T_timestamp, [], annot) -> - let+? () = check_type_annot loc annot in - return timestamp_t + let+ () = check_type_annot loc annot in + return ctxt timestamp_t | Prim (loc, T_address, [], annot) -> - let+? () = check_type_annot loc annot in - return address_t + let+ () = check_type_annot loc annot in + return ctxt address_t | Prim (loc, T_signature, [], annot) -> - let+? () = check_type_annot loc annot in - return signature_t + let+ () = check_type_annot loc annot in + return ctxt signature_t | Prim (loc, T_operation, [], annot) -> if allow_operation then - let+? () = check_type_annot loc annot in - return operation_t + let+ () = check_type_annot loc annot in + return ctxt operation_t else tzfail (Unexpected_operation loc) | Prim (loc, T_chain_id, [], annot) -> - let+? () = check_type_annot loc annot in - return chain_id_t + let+ () = check_type_annot loc annot in + return ctxt chain_id_t | Prim (loc, T_never, [], annot) -> - let+? () = check_type_annot loc annot in - return never_t + let+ () = check_type_annot loc annot in + return ctxt never_t | Prim (loc, T_bls12_381_g1, [], annot) -> - let+? () = check_type_annot loc annot in - return bls12_381_g1_t + let+ () = check_type_annot loc annot in + return ctxt bls12_381_g1_t | Prim (loc, T_bls12_381_g2, [], annot) -> - let+? () = check_type_annot loc annot in - return bls12_381_g2_t + let+ () = check_type_annot loc annot in + return ctxt bls12_381_g2_t | Prim (loc, T_bls12_381_fr, [], annot) -> - let+? () = check_type_annot loc annot in - return bls12_381_fr_t + let+ () = check_type_annot loc annot in + return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - let*? () = check_type_annot loc annot in - let* (Ex_ty tl) = + let* () = check_type_annot loc annot in + let* Ex_ty tl, ctxt = parse_passable_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy utl ~ret:Don't_parse_entrypoints in - let+? ty = contract_t loc tl in - return ty + let+ ty = contract_t loc tl in + return ctxt ty else tzfail (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> - let*? () = check_type_annot loc annot in - let*? utl = remove_field_annot utl in - let* (Ex_ty tl) = + let* () = check_type_annot loc annot in + let* utl = remove_field_annot utl in + let* Ex_ty tl, ctxt = parse_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy ~allow_lazy_storage @@ -687,15 +691,16 @@ let rec parse_ty : ~ret:Don't_parse_entrypoints utl in - let*? utr = + let* utr = match utr with | [utr] -> remove_field_annot utr | utr -> (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) Ok (Prim (loc, T_pair, utr, [])) in - let* (Ex_ty tr) = + let* Ex_ty tr, ctxt = parse_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy ~allow_lazy_storage @@ -705,21 +710,21 @@ let rec parse_ty : ~ret:Don't_parse_entrypoints utr in - let+? (Ty_ex_c ty) = pair_t loc tl tr in - return ty + let+ (Ty_ex_c ty) = pair_t loc tl tr in + return ctxt ty | Prim (loc, T_or, [utl; utr], annot) -> ( - let*? () = check_type_annot loc annot in - let*? utl, utr = - let open Result_syntax in + let* () = check_type_annot loc annot in + let* utl, utr = match ret with | Don't_parse_entrypoints -> let* utl = remove_field_annot utl in let+ utr = remove_field_annot utr in (utl, utr) - | Parse_entrypoints -> return (utl, utr) + | Parse_entrypoints -> Ok (utl, utr) in - let* parsed_l = + let* parsed_l, ctxt = parse_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy ~allow_lazy_storage @@ -729,8 +734,9 @@ let rec parse_ty : ~ret utl in - let* parsed_r = + let* parsed_r, ctxt = parse_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy ~allow_lazy_storage @@ -744,8 +750,8 @@ let rec parse_ty : | Don't_parse_entrypoints -> let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in - let+? (Ty_ex_c ty) = or_t loc tl tr in - (Ex_ty ty : ret) + let+ (Ty_ex_c ty) = or_t loc tl tr in + ((Ex_ty ty : ret), ctxt) | Parse_entrypoints -> let (Ex_parameter_ty_and_entrypoints_node {arg_type = tl; entrypoints = left}) = @@ -755,7 +761,7 @@ let rec parse_ty : {arg_type = tr; entrypoints = right}) = parsed_r in - let+? (Ty_ex_c arg_type) = or_t loc tl tr in + let+ (Ty_ex_c arg_type) = or_t loc tl tr in let entrypoints = let at_node = Option.map @@ -764,21 +770,23 @@ let rec parse_ty : in {at_node; nested = Entrypoints_Or {left; right}} in - Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}) + ( Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, + ctxt )) | Prim (loc, T_lambda, [uta; utr], annot) -> - let*? () = check_type_annot loc annot in - let* (Ex_ty ta) = - parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy uta + let* () = check_type_annot loc annot in + let* Ex_ty ta, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta in - let* (Ex_ty tr) = - parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy utr + let* Ex_ty tr, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr in - let+? ty = lambda_t loc ta tr in - return ty + let+ ty = lambda_t loc ta tr in + return ctxt ty | Prim (loc, T_option, [ut], annot) -> - let*? () = check_type_annot loc annot in - let* (Ex_ty t) = + let* () = check_type_annot loc annot in + let* Ex_ty t, ctxt = parse_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy ~allow_lazy_storage @@ -788,12 +796,13 @@ let rec parse_ty : ~ret:Don't_parse_entrypoints ut in - let+? ty = option_t loc t in - return ty + let+ ty = option_t loc t in + return ctxt ty | Prim (loc, T_list, [ut], annot) -> - let*? () = check_type_annot loc annot in - let* (Ex_ty t) = + let* () = check_type_annot loc annot in + let* Ex_ty t, ctxt = parse_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy ~allow_lazy_storage @@ -803,31 +812,32 @@ let rec parse_ty : ~ret:Don't_parse_entrypoints ut in - let+? ty = list_t loc t in - return ty + let+ ty = list_t loc t in + return ctxt ty | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then - let*? () = check_type_annot loc annot in - let* (Ex_comparable_ty t) = - parse_comparable_ty ~stack_depth:(stack_depth + 1) ut + let* () = check_type_annot loc annot in + let* Ex_comparable_ty t, ctxt = + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut in - let+? ty = ticket_t loc t in - return ty + let+ ty = ticket_t loc t in + return ctxt ty else tzfail (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - let*? () = check_type_annot loc annot in - let* (Ex_comparable_ty t) = - parse_comparable_ty ~stack_depth:(stack_depth + 1) ut + let* () = check_type_annot loc annot in + let* Ex_comparable_ty t, ctxt = + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut in - let+? ty = set_t loc t in - return ty + let+ ty = set_t loc t in + return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - let*? () = check_type_annot loc annot in - let* (Ex_comparable_ty ta) = - parse_comparable_ty ~stack_depth:(stack_depth + 1) uta + let* () = check_type_annot loc annot in + let* Ex_comparable_ty ta, ctxt = + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta in - let* (Ex_ty tr) = + let* Ex_ty tr, ctxt = parse_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy ~allow_lazy_storage @@ -837,17 +847,17 @@ let rec parse_ty : ~ret:Don't_parse_entrypoints utr in - let+? ty = map_t loc ta tr in - return ty + let+ ty = map_t loc ta tr in + return ctxt ty | Prim (loc, T_sapling_transaction, [memo_size], annot) -> - let*? () = check_type_annot loc annot in - let+? memo_size = parse_memo_size memo_size in - return (sapling_transaction_t ~memo_size) + let* () = check_type_annot loc annot in + let+ memo_size = parse_memo_size memo_size in + return ctxt (sapling_transaction_t ~memo_size) | Prim (loc, T_sapling_transaction_deprecated, [memo_size], annot) -> if legacy (* Legacy check introduced in Jakarta. *) then - let*? () = check_type_annot loc annot in - let+? memo_size = parse_memo_size memo_size in - return (sapling_transaction_deprecated_t ~memo_size) + let* () = check_type_annot loc annot in + let+ memo_size = parse_memo_size memo_size in + return ctxt (sapling_transaction_deprecated_t ~memo_size) else tzfail (Deprecated_instruction T_sapling_transaction_deprecated) (* /!\ When adding new lazy storage kinds, be careful to use @@ -856,20 +866,21 @@ let rec parse_ty : from another contract with `PUSH t id` or `UNPACK`. *) | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> - let+ (Ex_ty ty) = + let+ Ex_ty ty, ctxt = parse_big_map_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy loc args annot in - return ty + return ctxt ty | Prim (loc, T_sapling_state, [memo_size], annot) when allow_lazy_storage -> - let*? () = check_type_annot loc annot in - let+? memo_size = parse_memo_size memo_size in - return (sapling_state_t ~memo_size) + let* () = check_type_annot loc annot in + let+ memo_size = parse_memo_size memo_size in + return ctxt (sapling_state_t ~memo_size) | Prim (loc, (T_big_map | T_sapling_state), _, _) -> tzfail (Unexpected_lazy_storage loc) | Prim @@ -926,14 +937,16 @@ let rec parse_ty : ] and parse_comparable_ty : + context -> stack_depth:int -> Script.node -> - (ex_comparable_ty, error trace) Gas_monad.t = - let open Gas_monad.Syntax in - fun ~stack_depth node -> - let* (Ex_ty t) = + (ex_comparable_ty * context) tzresult = + let open Result_syntax in + fun ctxt ~stack_depth node -> + let* Ex_ty t, ctxt = parse_ty ~ret:Don't_parse_entrypoints + ctxt ~stack_depth:(stack_depth + 1) ~legacy:false ~allow_lazy_storage:false @@ -943,7 +956,7 @@ and parse_comparable_ty : node in match is_comparable t with - | Yes -> return (Ex_comparable_ty t) + | Yes -> return (Ex_comparable_ty t, ctxt) | No -> tzfail (Comparable_type_expected @@ -951,13 +964,15 @@ and parse_comparable_ty : and parse_passable_ty : type ret name. + context -> stack_depth:int -> legacy:bool -> ret:(ret, name) parse_ty_ret -> Script.node -> - (ret, error trace) Gas_monad.t = - fun ~stack_depth ~legacy -> + (ret * context) tzresult = + fun ctxt ~stack_depth ~legacy -> (parse_ty [@tailcall]) + ctxt ~stack_depth ~legacy ~allow_lazy_storage:true @@ -966,12 +981,14 @@ and parse_passable_ty : ~allow_ticket:true and parse_any_ty : + context -> stack_depth:int -> legacy:bool -> Script.node -> - (ex_ty, error trace) Gas_monad.t = - fun ~stack_depth ~legacy -> + (ex_ty * context) tzresult = + fun ctxt ~stack_depth ~legacy -> (parse_ty [@tailcall]) + ctxt ~stack_depth ~legacy ~allow_lazy_storage:true @@ -980,24 +997,29 @@ and parse_any_ty : ~allow_ticket:true ~ret:Don't_parse_entrypoints -and parse_big_map_ty ~stack_depth ~legacy big_map_loc args map_annot = - let open Gas_monad.Syntax in - let* () = Gas_monad.consume_gas Typecheck_costs.parse_type_cycle in +and parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc args map_annot = + let open Result_syntax in + let* ctxt = Gas.consume ctxt Typecheck_costs.parse_type_cycle in match args with | [key_ty; value_ty] -> - let*? () = check_type_annot big_map_loc map_annot in - let* (Ex_comparable_ty key_ty) = - parse_comparable_ty ~stack_depth:(stack_depth + 1) key_ty + let* () = check_type_annot big_map_loc map_annot in + let* Ex_comparable_ty key_ty, ctxt = + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty in - let* (Ex_ty value_ty) = - parse_big_map_value_ty ~stack_depth:(stack_depth + 1) ~legacy value_ty + let* Ex_ty value_ty, ctxt = + parse_big_map_value_ty + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy + value_ty in - let+? big_map_ty = big_map_t big_map_loc key_ty value_ty in - Ex_ty big_map_ty + let+ big_map_ty = big_map_t big_map_loc key_ty value_ty in + (Ex_ty big_map_ty, ctxt) | args -> tzfail @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and parse_big_map_value_ty ~stack_depth ~legacy value_ty = +and parse_big_map_value_ty ctxt ~stack_depth ~legacy value_ty = (parse_ty [@tailcall]) + ctxt ~stack_depth ~legacy ~allow_lazy_storage:false @@ -1007,8 +1029,9 @@ and parse_big_map_value_ty ~stack_depth ~legacy value_ty = ~ret:Don't_parse_entrypoints value_ty -let parse_packable_ty ~stack_depth ~legacy node = +let parse_packable_ty ctxt ~stack_depth ~legacy node = (parse_ty [@tailcall]) + ctxt ~stack_depth ~legacy ~allow_lazy_storage:false @@ -1020,8 +1043,9 @@ let parse_packable_ty ~stack_depth ~legacy node = ~ret:Don't_parse_entrypoints node -let parse_view_input_ty ~stack_depth ~legacy node = +let parse_view_input_ty ctxt ~stack_depth ~legacy node = (parse_ty [@tailcall]) + ctxt ~stack_depth ~legacy ~allow_lazy_storage:false @@ -1031,8 +1055,9 @@ let parse_view_input_ty ~stack_depth ~legacy node = ~ret:Don't_parse_entrypoints node -let parse_view_output_ty ~stack_depth ~legacy node = +let parse_view_output_ty ctxt ~stack_depth ~legacy node = (parse_ty [@tailcall]) + ctxt ~stack_depth ~legacy ~allow_lazy_storage:false @@ -1042,8 +1067,9 @@ let parse_view_output_ty ~stack_depth ~legacy node = ~ret:Don't_parse_entrypoints node -let parse_storage_ty ~stack_depth ~legacy node = +let parse_storage_ty ctxt ~stack_depth ~legacy node = (parse_ty [@tailcall]) + ctxt ~stack_depth ~legacy ~allow_lazy_storage:true @@ -1386,26 +1412,27 @@ type ex_parameter_ty_and_entrypoints = -> ex_parameter_ty_and_entrypoints let parse_parameter_ty_and_entrypoints : + context -> stack_depth:int -> legacy:bool -> Script.node -> - (ex_parameter_ty_and_entrypoints, error trace) Gas_monad.t = - let open Gas_monad.Syntax in - fun ~stack_depth ~legacy node -> - let* (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}) = + (ex_parameter_ty_and_entrypoints * context) tzresult = + let open Result_syntax in + fun ctxt ~stack_depth ~legacy node -> + let* Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt = parse_passable_ty + ctxt ~stack_depth:(stack_depth + 1) ~legacy node ~ret:Parse_entrypoints in - let+? () = - if legacy (* Legacy check introduced before Ithaca. *) then - Result.return_unit + let+ () = + if legacy (* Legacy check introduced before Ithaca. *) then return_unit else well_formed_entrypoints arg_type entrypoints in let entrypoints = {root = entrypoints; original_type_expr = node} in - Ex_parameter_ty_and_entrypoints {arg_type; entrypoints} + (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints @@ -2269,30 +2296,29 @@ let rec parse_data : match tys_opt with | None -> traced_fail (Invalid_big_map (loc, id)) | Some (btk, btv) -> - let*? res, ctxt = + let*? Ex_comparable_ty btk, ctxt = + parse_comparable_ty + ~stack_depth:(stack_depth + 1) + ctxt + (Micheline.root btk) + in + let*? Ex_ty btv, ctxt = + parse_big_map_value_ty + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy + (Micheline.root btv) + in + let*? eq, 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 + 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) + let*? Eq = eq in + return (Some id, ctxt) else traced_fail (Unexpected_forged_value loc) in (Big_map {id; diff; key_type = tk; value_type = tv}, ctxt) @@ -2425,27 +2451,20 @@ and parse_view : {input_ty; output_ty; view_code} -> let legacy = elab_conf.legacy in let input_ty_loc = location input_ty in - let*? res, ctxt = - Gas_monad.run ctxt @@ parse_view_input_ty ~stack_depth:0 ~legacy input_ty - in - let*? (Ex_ty input_ty) = + let*? Ex_ty input_ty, ctxt = record_trace_eval (fun () -> Ill_formed_type (Some "arg of view", strip_locations input_ty, input_ty_loc)) - res + (parse_view_input_ty ctxt ~stack_depth:0 ~legacy input_ty) in let output_ty_loc = location output_ty in - let*? res, ctxt = - Gas_monad.run ctxt - @@ parse_view_output_ty ~stack_depth:0 ~legacy output_ty - in - let*? (Ex_ty output_ty) = + let*? Ex_ty output_ty, ctxt = record_trace_eval (fun () -> Ill_formed_type (Some "return of view", strip_locations output_ty, output_ty_loc)) - res + (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) in let*? (Ty_ex_c pair_ty) = pair_t input_ty_loc input_ty storage_type in let* judgement, ctxt = @@ -2844,11 +2863,9 @@ and parse_instr : typed ctxt 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, ctxt = + parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t in - let*? (Ex_ty t) = t in let* v, ctxt = parse_data ~unparse_code_rec @@ -2872,11 +2889,9 @@ and parse_instr : let*? ty = option_t loc t in typed ctxt 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 + let*? Ex_ty t, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t in - let*? (Ex_ty t) = 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 @@ -3030,22 +3045,18 @@ and parse_instr : typed ctxt 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, ctxt = + parse_any_ty ctxt ~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 | 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, ctxt = + parse_any_ty ctxt ~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 @@ -3078,11 +3089,9 @@ and parse_instr : Lwt.return @@ merge_branches ctxt 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 + let*? Ex_ty t, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t in - let*? (Ex_ty t) = 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 @@ -3192,11 +3201,9 @@ and parse_instr : ) (* 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, ctxt = + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt 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 @@ -3250,16 +3257,12 @@ and parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> - let*? tk, ctxt = - Gas_monad.run ctxt - @@ parse_comparable_ty ~stack_depth:(stack_depth + 1) tk + let*? Ex_comparable_ty tk, ctxt = + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk in - let*? (Ex_comparable_ty tk) = tk in - let*? tv, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy tv + let*? Ex_ty tv, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv in - let*? (Ex_ty tv) = tv in let*? () = check_var_type_annot loc annot in let instr = {apply = (fun k -> IEmpty_map (loc, tk, for_logging_only tv, k))} @@ -3374,16 +3377,12 @@ and parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> - let*? tk, ctxt = - Gas_monad.run ctxt - @@ parse_comparable_ty ~stack_depth:(stack_depth + 1) tk + let*? Ex_comparable_ty tk, ctxt = + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk in - let*? (Ex_comparable_ty tk) = tk in - let*? tv, ctxt = - Gas_monad.run ctxt - @@ parse_big_map_value_ty ~stack_depth:(stack_depth + 1) ~legacy tv + let*? Ex_ty tv, ctxt = + parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv in - let*? (Ex_ty tv) = tv 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 @@ -3601,16 +3600,12 @@ and parse_instr : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> - let*? arg, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg + let*? Ex_ty arg, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg in - let*? (Ex_ty arg) = arg in - let*? ret, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret + let*? Ex_ty ret, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret in - let*? (Ex_ty ret) = ret in let*? () = check_kind [Seq_kind] code in let*? () = check_var_annot loc annot in let* kdescr, ctxt = @@ -3632,16 +3627,12 @@ and parse_instr : typed ctxt loc instr stack | ( Prim (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; lambda_expr], annot), stack ) -> - let*? arg, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr + let*? Ex_ty arg, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr in - let*? (Ex_ty arg) = arg in - let*? ret, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr + let*? Ex_ty ret, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr in - let*? (Ex_ty ret) = ret 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 @@ -4115,11 +4106,9 @@ and parse_instr : (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> let*? () = check_var_annot loc annot in - let*? cast_t, ctxt = - Gas_monad.run ctxt - @@ parse_any_ty ~stack_depth:(stack_depth + 1) ~legacy cast_t + let*? Ex_ty cast_t, ctxt = + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t in - let*? (Ex_ty cast_t) = cast_t in let*? eq, ctxt = Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t in @@ -4145,11 +4134,9 @@ and parse_instr : let stack = Item_t (bytes_t, rest) in typed ctxt 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, ctxt = + parse_packable_ty ctxt ~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 @@ -4162,11 +4149,9 @@ and parse_instr : let stack = Item_t (address_t, rest) in typed ctxt 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, ctxt = + parse_passable_ty ctxt ~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 @@ -4177,11 +4162,9 @@ and parse_instr : Item_t (input_ty, Item_t (Address_t, rest)) ) -> let output_ty_loc = location output_ty in let*? name, ctxt = parse_view_name ctxt name in - let*? output_ty, ctxt = - Gas_monad.run ctxt - @@ parse_view_output_ty ~stack_depth:0 ~legacy output_ty + let*? Ex_ty output_ty, ctxt = + parse_view_output_ty ctxt ~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 = @@ -4232,27 +4215,24 @@ and parse_instr : let*? {arg_type; storage_type; code_field; views}, ctxt = parse_toplevel ctxt canonical_code in - let*? arg_type_with_entrypoints, ctxt = - Gas_monad.run ctxt - @@ parse_parameter_ty_and_entrypoints - ~stack_depth:(stack_depth + 1) - ~legacy - arg_type - in - let*? (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt = record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) - arg_type_with_entrypoints - in - let*? res, ctxt = - Gas_monad.run ctxt - @@ parse_storage_ty ~stack_depth:(stack_depth + 1) ~legacy storage_type + (parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy + arg_type) in - let*? (Ex_ty storage_type) = + let*? Ex_ty storage_type, ctxt = record_trace (Ill_formed_type (Some "storage", canonical_code, location storage_type)) - res + (parse_storage_ty + ctxt + ~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) = @@ -4577,11 +4557,9 @@ and parse_instr : in typed ctxt 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, ctxt = + parse_packable_ty ctxt ~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*? tag = parse_entrypoint_annot_strict loc annot in let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost ty_node) in @@ -4890,16 +4868,14 @@ and parse_contract : in (* can only fail because of gas *) let*? {arg_type; _}, ctxt = parse_toplevel ctxt code in - let*? targ, ctxt = - Gas_monad.run ctxt - @@ parse_parameter_ty_and_entrypoints - ~stack_depth:(stack_depth + 1) - ~legacy:true - arg_type - in - let*? (Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}) = - targ + let*? ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) = + parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy:true + arg_type in let*? entrypoint_arg, ctxt = Gas_monad.run ctxt @@ -4944,16 +4920,14 @@ and parse_contract : 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 + let*? ( Ex_parameter_ty_and_entrypoints + {arg_type = full; entrypoints}, + ctxt ) = + parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy:true + (root parameters_type) in let*? entrypoint_arg, ctxt = Gas_monad.run ctxt @@ -5039,21 +5013,20 @@ let parse_code : parse_toplevel ctxt code in let arg_type_loc = location arg_type in - let*? res, ctxt = - Gas_monad.run ctxt - @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type - in - let*? (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = - record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) res + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt = + record_trace + (Ill_formed_type (Some "parameter", code, arg_type_loc)) + (parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:0 + ~legacy + arg_type) in let storage_type_loc = location storage_type in - let*? storage_type, ctxt = - Gas_monad.run ctxt @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type - in - let*? (Ex_ty storage_type) = + let*? Ex_ty storage_type, ctxt = record_trace (Ill_formed_type (Some "storage", code, storage_type_loc)) - storage_type + (parse_storage_ty ctxt ~stack_depth:0 ~legacy storage_type) in let*? (Ty_ex_c arg_type_full) = pair_t storage_type_loc arg_type storage_type @@ -5173,24 +5146,22 @@ let typecheck_code : let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in - let*? arg_type, ctxt = - Gas_monad.run ctxt - @@ parse_parameter_ty_and_entrypoints ~stack_depth:0 ~legacy arg_type - in - let*? (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}) = + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt = record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - arg_type + (parse_parameter_ty_and_entrypoints + ctxt + ~stack_depth:0 + ~legacy + arg_type) in let storage_type_loc = location storage_type in let*? ex_storage_type, ctxt = - Gas_monad.run ctxt @@ parse_storage_ty ~stack_depth:0 ~legacy storage_type - in - let*? (Ex_ty storage_type) = record_trace (Ill_formed_type (Some "storage", code, storage_type_loc)) - ex_storage_type + (parse_storage_ty ctxt ~stack_depth:0 ~legacy storage_type) in + let (Ex_ty storage_type) = ex_storage_type in let*? (Ty_ex_c arg_type_full) = pair_t storage_type_loc arg_type storage_type in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index ba0001b51556..7cb107ef2c8a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -232,56 +232,36 @@ val parse_instr : the `value` in `big_map key value`. *) val parse_big_map_value_ty : - legacy:bool -> Script.node -> (ex_ty, error trace) Gas_monad.t + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult -(** - [parse_ty] specialized for packable types. -*) val parse_packable_ty : - legacy:bool -> Script.node -> (ex_ty, error trace) Gas_monad.t + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult -(** - [parse_ty] specialized for types which can be passed as parameter of - contract calls. See also [parse_parameter_ty_and_entrypoints]. -*) val parse_passable_ty : - legacy:bool -> Script.node -> (ex_ty, error trace) Gas_monad.t + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult -(** - [parse_ty] specialized for comparable types. -*) val parse_comparable_ty : - Script.node -> (ex_comparable_ty, error trace) Gas_monad.t + context -> Script.node -> (ex_comparable_ty * context) tzresult -(** - [parse_ty] specialized for the parameter type declared with the - `parameter` toplevel primitive. This function also returns typed - information about the available entrypoints. -*) val parse_parameter_ty_and_entrypoints : + context -> legacy:bool -> Script.node -> - (ex_parameter_ty_and_entrypoints, error trace) Gas_monad.t + (ex_parameter_ty_and_entrypoints * context) tzresult -(** - [parse_ty] specialized for the types which are allowed as inputs for - views. -*) val parse_view_input_ty : + context -> stack_depth:int -> legacy:bool -> Script.node -> - (ex_ty, error trace) Gas_monad.t + (ex_ty * context) tzresult -(** - [parse_ty] specialized for the types which are allowed as outputs - for views. -*) val parse_view_output_ty : + context -> stack_depth:int -> legacy:bool -> Script.node -> - (ex_ty, error trace) Gas_monad.t + (ex_ty * context) tzresult val parse_view : elab_conf:Script_ir_translator_config.elab_config -> @@ -301,19 +281,20 @@ val parse_views : [parse_ty] allowing big_map values, operations, contract and tickets. *) val parse_any_ty : - legacy:bool -> Script.node -> (ex_ty, error trace) Gas_monad.t + context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult (** We expose [parse_ty] for convenience to external tools. Please use specialized versions such as [parse_packable_ty], [parse_passable_ty], [parse_comparable_ty], or [parse_big_map_value_ty] if possible. *) val parse_ty : + context -> legacy:bool -> allow_lazy_storage:bool -> allow_operation:bool -> allow_contract:bool -> allow_ticket:bool -> Script.node -> - (ex_ty, error trace) Gas_monad.t + (ex_ty * context) tzresult val parse_toplevel : context -> Script.expr -> (toplevel * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 7500eb26480d..c0ee0267c98d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -489,10 +489,11 @@ module type MICHELSON_PARSER = sig tzresult val parse_packable_ty : + context -> stack_depth:int -> legacy:bool -> Script.node -> - (ex_ty, error trace) Gas_monad.t + (ex_ty * context) tzresult val parse_data : unparse_code_rec:unparse_code_rec -> @@ -786,14 +787,13 @@ module Data_unparser (P : MICHELSON_PARSER) = struct 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, ctxt = + P.parse_packable_ty + ctxt + ~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, diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 965d95e8403d..befe63181cb0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -170,10 +170,11 @@ module type MICHELSON_PARSER = sig tzresult val parse_packable_ty : + context -> stack_depth:int -> legacy:bool -> Script.node -> - (ex_ty, error trace) Gas_monad.t + (ex_ty * context) tzresult val parse_data : unparse_code_rec:unparse_code_rec -> diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 3d4c29b44b3f..f2be1305e0fe 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 @@ -76,11 +76,10 @@ let string_list_of_ex_token_diffs ctxt token_diffs = let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = let open Lwt_result_wrap_syntax in - let*?@ res, ctxt = + let*?@ Script_ir_translator.Ex_comparable_ty contents_type, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty node + Script_ir_translator.parse_comparable_ty ctxt node in - let*?@ (Script_ir_translator.Ex_comparable_ty contents_type) = res in let*?@ ticketer = Contract.of_b58check ticketer in let*@ contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml index 2f8c6ec70eaf..419642d47780 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_balance_key.ml @@ -47,11 +47,10 @@ let make_contract ticketer = let make_ex_token ctxt ~ticketer ~ty ~content = let open Lwt_result_wrap_syntax in - let*?@ res, ctxt = + let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string ty in - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty node + Script_ir_translator.parse_comparable_ty ctxt node in - let*?@ (Script_ir_translator.Ex_comparable_ty cty) = res in let* ticketer = make_contract ticketer in let*@ contents, ctxt = let node = Micheline.root @@ Expr.from_string content in 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..c0eab214e0a5 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 @@ -66,11 +66,10 @@ let string_list_of_ex_token_diffs ctxt token_diffs = let make_ex_token ctxt ~ticketer ~type_exp ~content_exp = let open Lwt_result_wrap_syntax in - let*?@ res, ctxt = + let*?@ Script_ir_translator.Ex_comparable_ty contents_type, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty node + Script_ir_translator.parse_comparable_ty ctxt node in - let*?@ (Script_ir_translator.Ex_comparable_ty contents_type) = res in let*@ ticketer = Lwt.return @@ Contract.of_b58check ticketer in let*@ contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index cc4c193a2094..f5a6f50d7a33 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -97,11 +97,10 @@ let string_list_of_ex_tickets ctxt tickets = let make_ex_ticket ctxt ~ticketer ~type_exp ~content_exp ~amount = let open Lwt_result_wrap_syntax in - let*?@ res, ctxt = + let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty node + Script_ir_translator.parse_comparable_ty ctxt node in - let*?@ (Script_ir_translator.Ex_comparable_ty cty) = res in let*?@ ticketer = Contract.of_b58check ticketer in let*@ contents, ctxt = let node = Micheline.root @@ Expr.from_string content_exp in @@ -126,12 +125,11 @@ let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = let tickets_of_value ctxt ~include_lazy ~type_exp ~value_exp = let open Lwt_result_wrap_syntax in - let*?@ res, ctxt = + let Script_typed_ir.Ex_ty ty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in - Gas_monad.run ctxt @@ Script_ir_translator.parse_any_ty ~legacy:false node - in - let (Script_typed_ir.Ex_ty ty) = - Result.value_f ~default:(fun () -> Stdlib.failwith "Failed to parse") res + Result.value_f + ~default:(fun () -> Stdlib.failwith "Failed to parse") + (Script_ir_translator.parse_any_ty ctxt ~legacy:false node) in let node = Micheline.root @@ Expr.from_string value_exp in let*@ value, ctxt = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 5faf2ce4e7b3..990cbd765147 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -209,35 +209,28 @@ let location = function let test_parse_ty (type exp expc) ctxt node (expected : (exp, expc) Script_typed_ir.ty) = - let open Result_syntax in let legacy = false in let allow_lazy_storage = true in let allow_operation = true in let allow_contract = true in let allow_ticket = true in - let* res, ctxt = - Environment.wrap_tzresult @@ Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* (Script_typed_ir.Ex_ty actual) = - Script_ir_translator.parse_ty + Environment.wrap_tzresult + ( Script_ir_translator.parse_ty + ctxt ~legacy ~allow_lazy_storage ~allow_operation ~allow_contract ~allow_ticket node - in - let* Eq = - Script_ir_translator.ty_eq - ~error_details:(Informative (location node)) - actual - expected - in - return_unit - in - let* () = Environment.wrap_tzresult @@ res in - return ctxt + >>? fun (Script_typed_ir.Ex_ty actual, ctxt) -> + Gas_monad.run ctxt + @@ Script_ir_translator.ty_eq + ~error_details:(Informative (location node)) + actual + expected + >>? fun (eq, ctxt) -> + eq >|? fun Eq -> ctxt ) let test_parse_comb_type () = let open Lwt_result_wrap_syntax in @@ -796,12 +789,6 @@ let test_optimal_comb () = let* (_ : context) = check_optimal_comb __LOC__ ctxt comb5_ty comb5_v 5 in return_unit -let gas_monad_run ctxt m = - let open Result_syntax in - let* res, ctxt = Gas_monad.run ctxt m in - let+ res in - (res, ctxt) - (* Check that UNPACK on contract is forbidden. See https://gitlab.com/tezos/tezos/-/issues/301 for the motivation behind this restriction. @@ -816,8 +803,7 @@ let test_contract_not_packable () = (* Test that [contract_unit] is parsable *) let* () = match - gas_monad_run ctxt - @@ Script_ir_translator.parse_any_ty ~legacy:false contract_unit + Script_ir_translator.parse_any_ty ctxt ~legacy:false contract_unit with | Ok _ -> Lwt_result_syntax.return_unit | Error _ -> Alcotest.failf "Could not parse (contract unit)" @@ -825,8 +811,7 @@ let test_contract_not_packable () = (* Test that [contract_unit] is not packable *) let* () = match - gas_monad_run ctxt - @@ Script_ir_translator.parse_packable_ty ~legacy:false contract_unit + Script_ir_translator.parse_packable_ty ctxt ~legacy:false contract_unit with | Ok _ -> Alcotest.failf diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_transfer_ticket.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_transfer_ticket.ml index 3a84e45d0317..29f55e012eb9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_transfer_ticket.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_transfer_ticket.ml @@ -114,11 +114,9 @@ let test_mint_deposit_withdraw_implicit_transfer () = Block.bake ~operation block in let make_ex_token ctxt ~ticketer ~ty ~content = - let*?@ res, ctxt = - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty - @@ Micheline.root ty + let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = + Script_ir_translator.parse_comparable_ty ctxt @@ Micheline.root ty in - let*?@ (Script_ir_translator.Ex_comparable_ty cty) = res in let*@ contents, ctxt = Script_ir_translator.parse_comparable_data ctxt cty @@ Micheline.root content @@ -258,11 +256,9 @@ let test_contract_as_ticket_transfer_destination () = Block.bake ~operation block in let make_ex_token ctxt ~ticketer ~ty ~content = - let*?@ res, ctxt = - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty - @@ Micheline.root ty + let*?@ Script_ir_translator.Ex_comparable_ty cty, ctxt = + Script_ir_translator.parse_comparable_ty ctxt @@ Micheline.root ty in - let*?@ (Script_ir_translator.Ex_comparable_ty cty) = res in let*@ contents, ctxt = Script_ir_translator.parse_comparable_data ctxt cty @@ Micheline.root content diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml index 80a8a3f7f9f3..81db05c947ed 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml @@ -321,10 +321,9 @@ let make_ticket_key ctxt ~ty ~contents ~ticketer zk_rollup = | Context.I incr -> return incr in let ctxt = Incremental.alpha_ctxt incr in - let*?@ res, ctxt = - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty ty + let*?@ Ex_comparable_ty contents_type, ctxt = + Script_ir_translator.parse_comparable_ty ctxt ty in - let*?@ (Ex_comparable_ty contents_type) = res in let*@ contents, ctxt = Script_ir_translator.parse_comparable_data ctxt contents_type contents in diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index 7b02f32c31ef..79cd92e929f7 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -68,8 +68,9 @@ let neg_token_and_amount ctxt ex_ticket = let+ ctxt = Gas.consume ctxt (Ticket_costs.negate_cost amount) in ((token, Z.neg amount), ctxt) -let parse_value_type value_type = +let parse_value_type ctxt value_type = Script_ir_translator.parse_big_map_value_ty + ctxt ~legacy:true (Micheline.root value_type) @@ -188,8 +189,9 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates We should have the non-serialized version of the value type. *) let open Lwt_result_syntax in - let*? res, ctxt = Gas_monad.run ctxt @@ parse_value_type value_type in - let*? (Script_typed_ir.Ex_ty value_type) = res in + let*? Script_typed_ir.Ex_ty value_type, ctxt = + parse_value_type ctxt value_type + in let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt value_type in let+ acc, _already_updated, ctxt = List.fold_left_es @@ -221,8 +223,9 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = In order to find tickets from the value, we need to parse the value type. It would be more efficient if the value preserved. *) - let*? res, ctxt = Gas_monad.run ctxt @@ parse_value_type value_ty in - let*? (Script_typed_ir.Ex_ty value_type) = res in + let*? Script_typed_ir.Ex_ty value_type, ctxt = + parse_value_type ctxt value_ty + in let*? has_tickets, ctxt = Ticket_scanner.type_has_tickets ctxt value_type in diff --git a/src/proto_alpha/lib_protocol/ticket_transfer.ml b/src/proto_alpha/lib_protocol/ticket_transfer.ml index 8aa3b8a45d0d..068ccaecbaa1 100644 --- a/src/proto_alpha/lib_protocol/ticket_transfer.ml +++ b/src/proto_alpha/lib_protocol/ticket_transfer.ml @@ -34,11 +34,9 @@ let parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt = let*? contents, ctxt = Script.force_decode_in_context ~consume_deserialization_gas ctxt contents in - let*? res, ctxt = - Gas_monad.run ctxt - @@ Script_ir_translator.parse_comparable_ty (Micheline.root ty) + let*? Ex_comparable_ty contents_type, ctxt = + Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) in - let*? (Ex_comparable_ty contents_type) = res in let* contents, ctxt = Script_ir_translator.parse_comparable_data ctxt diff --git a/src/proto_alpha/lib_protocol/zk_rollup_apply.ml b/src/proto_alpha/lib_protocol/zk_rollup_apply.ml index 0191dc01f276..2027fe6416de 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_apply.ml +++ b/src/proto_alpha/lib_protocol/zk_rollup_apply.ml @@ -86,11 +86,9 @@ let originate ~ctxt_before_op ~ctxt ~public_parameters ~circuits_info individual parts submitted as part of a Zk_rollup_publish operation. *) let parse_ticket ~ticketer ~contents ~ty ctxt = let open Lwt_result_syntax in - let*? res, ctxt = - Gas_monad.run ctxt - @@ Script_ir_translator.parse_comparable_ty (Micheline.root ty) + let*? Ex_comparable_ty contents_type, ctxt = + Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) in - let*? (Ex_comparable_ty contents_type) = res in let* contents, ctxt = Script_ir_translator.parse_comparable_data ctxt -- GitLab From 47b0f0917afcded6b0e04f0cf97215e91b5a2d09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:13:17 +0200 Subject: [PATCH 06/16] Revert "Proto/Michelson: put hash_bytes in the Gas monad" This reverts commit fb6ed0edbb5a3a16a4462495084d2ecb58e4a22d. --- .../lib_protocol/script_ir_translator.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 0b7acfd83017..b19eadd8f4da 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -168,17 +168,17 @@ let pack_comparable_data ctxt ty data = let+ unparsed, ctxt = unparse_comparable_data ctxt Optimized_legacy ty data in pack_node unparsed ctxt -let hash_bytes bytes = - let open Gas_monad.Syntax in - let+ () = - Gas_monad.consume_gas (Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes) +let hash_bytes ctxt bytes = + let open Result_syntax in + let+ ctxt = + Gas.consume ctxt (Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes) in - Script_expr_hash.(hash_bytes [bytes]) + (Script_expr_hash.(hash_bytes [bytes]), ctxt) let hash_comparable_data ctxt ty data = let open Lwt_result_syntax in let* bytes, ctxt = pack_comparable_data ctxt ty data in - Lwt.return @@ Gas_monad.run_pure ctxt @@ hash_bytes bytes + Lwt.return @@ hash_bytes ctxt bytes (* ---- Tickets ------------------------------------------------------------ *) @@ -5384,7 +5384,7 @@ let pack_data_with_mode ctxt ty data ~mode = let hash_data ctxt ty data = let open Lwt_result_syntax in let* bytes, ctxt = pack_data_with_mode ctxt ty data ~mode:Optimized_legacy in - Lwt.return @@ Gas_monad.run_pure ctxt @@ hash_bytes bytes + Lwt.return @@ hash_bytes ctxt bytes let pack_data ctxt ty data = pack_data_with_mode ctxt ty data ~mode:Optimized_legacy -- GitLab From 979c202c76c1909ce43d9115fd201f5b554a04f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:13:19 +0200 Subject: [PATCH 07/16] Revert "Proto/Michelson: put unparsing funs for atomic data in gas monad" This reverts commit f8dfe24696eb83445d71f80f18783110ca80b31a. --- .../lib_protocol/script_ir_unparser.ml | 249 ++++++++---------- .../lib_protocol/script_ir_unparser.mli | 45 ++-- 2 files changed, 137 insertions(+), 157 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index c0ee0267c98d..ab507207a841 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -187,146 +187,145 @@ let serialize_stack_for_error ctxt stack_ty = | Unaccounted -> unparse_stack_uncarbonated stack_ty | Limited _ -> [] -let unparse_unit ~loc () = Gas_monad.return (Prim (loc, D_Unit, [], [])) +let unparse_unit ~loc ctxt () = Ok (Prim (loc, D_Unit, [], []), ctxt) -let unparse_int ~loc v = Gas_monad.return (Int (loc, Script_int.to_zint v)) +let unparse_int ~loc ctxt v = Ok (Int (loc, Script_int.to_zint v), ctxt) -let unparse_nat ~loc v = Gas_monad.return (Int (loc, Script_int.to_zint v)) +let unparse_nat ~loc ctxt v = Ok (Int (loc, Script_int.to_zint v), ctxt) -let unparse_string ~loc s = - Gas_monad.return (String (loc, Script_string.to_string s)) +let unparse_string ~loc ctxt s = + Ok (String (loc, Script_string.to_string s), ctxt) -let unparse_bytes ~loc s = Gas_monad.return (Bytes (loc, s)) +let unparse_bytes ~loc ctxt s = Ok (Bytes (loc, s), ctxt) -let unparse_bool ~loc b = - Gas_monad.return (Prim (loc, (if b then D_True else D_False), [], [])) +let unparse_bool ~loc ctxt b = + Ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt) -let unparse_timestamp ~loc mode t = - let open Gas_monad.Syntax in +let unparse_timestamp ~loc ctxt mode t = + let open Result_syntax in match mode with | Optimized | Optimized_legacy -> - return (Int (loc, Script_timestamp.to_zint t)) + return (Int (loc, Script_timestamp.to_zint t), ctxt) | Readable -> ( - let+ () = Gas_monad.consume_gas Unparse_costs.timestamp_readable in + let* ctxt = Gas.consume ctxt Unparse_costs.timestamp_readable in match Script_timestamp.to_notation t with - | None -> Int (loc, Script_timestamp.to_zint t) - | Some s -> String (loc, s)) + | None -> return (Int (loc, Script_timestamp.to_zint t), ctxt) + | Some s -> return (String (loc, s), ctxt)) -let unparse_address ~loc mode {destination; entrypoint} = - let open Gas_monad.Syntax in +let unparse_address ~loc ctxt mode {destination; entrypoint} = + let open Result_syntax in match mode with | Optimized | Optimized_legacy -> - let+ () = Gas_monad.consume_gas Unparse_costs.contract_optimized in + let+ ctxt = Gas.consume ctxt Unparse_costs.contract_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding) (destination, entrypoint) in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) | Readable -> - let+ () = Gas_monad.consume_gas Unparse_costs.contract_readable in + let+ ctxt = Gas.consume ctxt Unparse_costs.contract_readable in let notation = Destination.to_b58check destination ^ Entrypoint.to_address_suffix entrypoint in - String (loc, notation) + (String (loc, notation), ctxt) -let unparse_contract ~loc mode typed_contract = +let unparse_contract ~loc ctxt mode typed_contract = let destination = Typed_contract.destination typed_contract in let entrypoint = Typed_contract.entrypoint typed_contract in let address = {destination; entrypoint} in - unparse_address ~loc mode address + unparse_address ~loc ctxt mode address -let unparse_signature ~loc mode s = - let open Gas_monad.Syntax in +let unparse_signature ~loc ctxt mode s = + let open Result_syntax in let s = Script_signature.get s in match mode with | Optimized | Optimized_legacy -> - let+ () = Gas_monad.consume_gas Unparse_costs.signature_optimized in + let+ ctxt = Gas.consume ctxt Unparse_costs.signature_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) | Readable -> - let+ () = Gas_monad.consume_gas Unparse_costs.signature_readable in - String (loc, Signature.to_b58check s) + let+ ctxt = Gas.consume ctxt Unparse_costs.signature_readable in + (String (loc, Signature.to_b58check s), ctxt) -let unparse_mutez ~loc v = - Gas_monad.return (Int (loc, Z.of_int64 (Tez.to_mutez v))) +let unparse_mutez ~loc ctxt v = Ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt) -let unparse_key ~loc mode k = - let open Gas_monad.Syntax in +let unparse_key ~loc ctxt mode k = + let open Result_syntax in match mode with | Optimized | Optimized_legacy -> - let+ () = Gas_monad.consume_gas Unparse_costs.public_key_optimized in + let+ ctxt = Gas.consume ctxt Unparse_costs.public_key_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) | Readable -> - let+ () = Gas_monad.consume_gas Unparse_costs.public_key_readable in - String (loc, Signature.Public_key.to_b58check k) + let+ ctxt = Gas.consume ctxt Unparse_costs.public_key_readable in + (String (loc, Signature.Public_key.to_b58check k), ctxt) -let unparse_key_hash ~loc mode k = - let open Gas_monad.Syntax in +let unparse_key_hash ~loc ctxt mode k = + let open Result_syntax in match mode with | Optimized | Optimized_legacy -> - let+ () = Gas_monad.consume_gas Unparse_costs.key_hash_optimized in + let+ ctxt = Gas.consume ctxt Unparse_costs.key_hash_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) | Readable -> - let+ () = Gas_monad.consume_gas Unparse_costs.key_hash_readable in - String (loc, Signature.Public_key_hash.to_b58check k) + let+ ctxt = Gas.consume ctxt Unparse_costs.key_hash_readable in + (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) (* Operations are only unparsed during the production of execution traces of the interpreter. *) -let unparse_operation ~loc {piop; lazy_storage_diff = _} = - let open Gas_monad.Syntax in +let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = + let open Result_syntax in let iop = Apply_internal_results.packed_internal_operation piop in let bytes = Data_encoding.Binary.to_bytes_exn Apply_internal_results.internal_operation_encoding iop in - let+ () = Gas_monad.consume_gas (Unparse_costs.operation bytes) in - Bytes (loc, bytes) + let+ ctxt = Gas.consume ctxt (Unparse_costs.operation bytes) in + (Bytes (loc, bytes), ctxt) -let unparse_chain_id ~loc mode chain_id = - let open Gas_monad.Syntax in +let unparse_chain_id ~loc ctxt mode chain_id = + let open Result_syntax in match mode with | Optimized | Optimized_legacy -> - let+ () = Gas_monad.consume_gas Unparse_costs.chain_id_optimized in + let+ ctxt = Gas.consume ctxt Unparse_costs.chain_id_optimized in let bytes = Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) | Readable -> - let+ () = Gas_monad.consume_gas Unparse_costs.chain_id_readable in - String (loc, Script_chain_id.to_b58check chain_id) + let+ ctxt = Gas.consume ctxt Unparse_costs.chain_id_readable in + (String (loc, Script_chain_id.to_b58check chain_id), ctxt) -let unparse_bls12_381_g1 ~loc x = - let open Gas_monad.Syntax in - let+ () = Gas_monad.consume_gas Unparse_costs.bls12_381_g1 in +let unparse_bls12_381_g1 ~loc ctxt x = + let open Result_syntax in + let+ ctxt = Gas.consume ctxt Unparse_costs.bls12_381_g1 in let bytes = Script_bls.G1.to_bytes x in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) -let unparse_bls12_381_g2 ~loc x = - let open Gas_monad.Syntax in - let+ () = Gas_monad.consume_gas Unparse_costs.bls12_381_g2 in +let unparse_bls12_381_g2 ~loc ctxt x = + let open Result_syntax in + let+ ctxt = Gas.consume ctxt Unparse_costs.bls12_381_g2 in let bytes = Script_bls.G2.to_bytes x in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) -let unparse_bls12_381_fr ~loc x = - let open Gas_monad.Syntax in - let+ () = Gas_monad.consume_gas Unparse_costs.bls12_381_fr in +let unparse_bls12_381_fr ~loc ctxt x = + let open Result_syntax in + let+ ctxt = Gas.consume ctxt Unparse_costs.bls12_381_fr in let bytes = Script_bls.Fr.to_bytes x in - Bytes (loc, bytes) + (Bytes (loc, bytes), ctxt) -let unparse_with_data_encoding ~loc s unparse_cost encoding = - let open Gas_monad.Syntax in - let+ () = Gas_monad.consume_gas unparse_cost in +let unparse_with_data_encoding ~loc ctxt s unparse_cost encoding = + let open Lwt_result_syntax in + let*? ctxt = Gas.consume ctxt unparse_cost in let bytes = Data_encoding.Binary.to_bytes_exn encoding s in - Bytes (loc, bytes) + return (Bytes (loc, bytes), ctxt) (* -- Unparsing data of complex types -- *) @@ -419,30 +418,20 @@ let rec unparse_comparable_data_rec : [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 + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k | Chain_id_t, chain_id -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_chain_id ~loc mode chain_id + Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id | Pair_t (tl, tr, _, YesYes), pair -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = @@ -528,44 +517,28 @@ module Data_unparser (P : MICHELSON_PARSER) = struct 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 + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t | Address_t, address -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_address ~loc mode address + Lwt.return @@ unparse_address ~loc ctxt 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 + Lwt.return @@ unparse_contract ~loc ctxt mode contract + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k | Operation_t, operation -> - Lwt.return @@ Gas_monad.run_pure ctxt - @@ unparse_operation ~loc operation + Lwt.return @@ unparse_operation ~loc ctxt 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 + Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id + | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt 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 @@ -739,20 +712,20 @@ module Data_unparser (P : MICHELSON_PARSER) = struct (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) | 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 + ctxt + 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 + ctxt + s + (Unparse_costs.chest + ~plaintext_size:(Script_timelock.get_plaintext_size s)) + Script_timelock.chest_encoding and unparse_items_rec : type k v vc. diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index befe63181cb0..787ddbce164f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -74,43 +74,49 @@ val unparse_parameter_ty : entrypoints:'a entrypoints -> ('loc Script.michelson_node, 'trace) Gas_monad.t -(** [unparse_bls12_381_g1 ~loc bls] returns the Micheline representation - of [bls] and consumes gas. *) +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) val unparse_bls12_381_g1 : loc:'loc -> + context -> Script_bls.G1.t -> - ('loc Script.michelson_node, 'trace) Gas_monad.t + ('loc Script.michelson_node * context, error trace) result -(** [unparse_bls12_381_g1 ~loc bls] returns the Micheline representation - of [bls] and consumes gas. *) +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) val unparse_bls12_381_g2 : loc:'loc -> + context -> Script_bls.G2.t -> - ('loc Script.michelson_node, 'trace) Gas_monad.t + ('loc Script.michelson_node * context, error trace) result -(** [unparse_bls12_381_g1 ~loc bls] returns the Micheline representation - of [bls] and consumes gas. *) +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) val unparse_bls12_381_fr : loc:'loc -> + context -> Script_bls.Fr.t -> - ('loc Script.michelson_node, 'trace) Gas_monad.t + ('loc Script.michelson_node * context, error trace) result -(** [unparse_operation ~loc op] returns the Micheline representation of - [op] and consumes gas. Useful only for producing execution +(** [unparse_operation ~loc ctxt op] returns the Micheline representation of + [op] and consumes gas from [ctxt]. Useful only for producing execution traces in the interpreter. *) val unparse_operation : loc:'loc -> + context -> Script_typed_ir.operation -> - ('loc Script.michelson_node, 'trace) Gas_monad.t + ('loc Script.michelson_node * context, error trace) result -(** [unparse_with_data_encoding ~loc v gas_cost enc] returns the bytes - representation of [v] wrapped in [Micheline.Bytes], consuming [gas_cost]. *) +(** [unparse_with_data_encoding ~loc ctxt v gas_cost enc] returns the bytes + representation of [v] wrapped in [Micheline.Bytes], consuming [gas_cost] + from [ctxt]. *) val unparse_with_data_encoding : loc:'loc -> + context -> 'a -> Gas.cost -> 'a Data_encoding.t -> - ('loc Script.michelson_node, 'trace) Gas_monad.t + ('loc Script.michelson_node * context, error trace) result Lwt.t (** [unparse_comparable_data ctxt unparsing_mode ty v] returns the Micheline representation of [v] of type [ty], consuming gas from @@ -122,14 +128,15 @@ val unparse_comparable_data : 'a -> (Script.expr * context) tzresult Lwt.t -(** [unparse_contract ~loc unparsin_mode contract] returns a Micheline - representation of a given contract in a given [unparsing_mode], and consumes - gas. *) +(** [unparse_contract ~loc ctxt unparsin_mode contract] returns a Micheline + representation of a given contract in a given [unparsing_mode]. Consumes + gas [ctxt]. *) val unparse_contract : loc:'loc -> + context -> unparsing_mode -> 'b typed_contract -> - ('loc Script.michelson_node, 'trace) Gas_monad.t + ('loc Script.michelson_node * context, error trace) result (** Lambdas are normalized at parsing and also at unparsing. These normalizations require to parse and unparse data appearing inside -- GitLab From bc94d48d84422b63eaa296f333b5f3e7619b03ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:13:21 +0200 Subject: [PATCH 08/16] Revert "Proto/Michelson: put unparse_parameter_ty in the gas monad" This reverts commit 644147c6cdfbcb9a3adcd37db3bd04e7643b9192. --- src/proto_alpha/lib_protocol/script_ir_unparser.ml | 8 ++++---- src/proto_alpha/lib_protocol/script_ir_unparser.mli | 5 +++-- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index ab507207a841..e6da79823abd 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -159,10 +159,10 @@ let unparse_ty ~loc ty = let+ () = Gas_monad.consume_gas (Unparse_costs.unparse_type ty) in unparse_ty_uncarbonated ~loc ty -let unparse_parameter_ty ~loc ty ~entrypoints = - let open Gas_monad.Syntax in - let+ () = Gas_monad.consume_gas (Unparse_costs.unparse_type ty) in - unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root +let unparse_parameter_ty ~loc ctxt ty ~entrypoints = + let open Result_syntax in + let+ ctxt = Gas.consume ctxt (Unparse_costs.unparse_type ty) in + (unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root, ctxt) let serialize_ty_for_error ty = (* diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 787ddbce164f..f6c0cae1872f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -65,14 +65,15 @@ val unparse_comparable_ty_uncarbonated : of [stack_ty]. Does not consume gas. *) val unparse_stack_uncarbonated : ('a, 's) stack_ty -> Script.expr list -(** [unparse_parameter_ty ~loc ty ~entrypoints] is a specialised version of +(** [unparse_parameter_ty ~loc ctxt ty ~entrypoints] is a specialised version of [unparse_ty], which also analyses [entrypoints] in order to annotate the returned type with adequate annotations. *) val unparse_parameter_ty : loc:'loc -> + context -> ('a, 'c) ty -> entrypoints:'a entrypoints -> - ('loc Script.michelson_node, 'trace) Gas_monad.t + ('loc Script.michelson_node * context, error trace) result (** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation of [bls] and consumes gas from [ctxt]. *) -- GitLab From d1a3a9c74b8448bd310a5b1b11b892e5911dcec8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:30 +0200 Subject: [PATCH 09/16] Revert "Proto/Michelson: put unparse_ty in the gas monad" This reverts commit 03680b01f7b628c4cfaad8ea06b3a37f7abc7d5f. --- devtools/get_contracts/get_contracts_alpha.ml | 16 ++++++------ .../translator_benchmarks.ml | 3 +-- src/proto_alpha/lib_plugin/RPC.ml | 4 +-- .../lib_protocol/contract_services.ml | 6 ++--- .../lib_protocol/script_interpreter_defs.ml | 9 +++---- .../lib_protocol/script_ir_translator.ml | 25 +++++-------------- .../lib_protocol/script_ir_unparser.ml | 8 +++--- .../lib_protocol/script_ir_unparser.mli | 9 ++++--- .../michelson/test_ticket_accounting.ml | 11 +++++--- .../michelson/test_typechecking.ml | 11 +++----- .../test/pbt/test_script_comparison.ml | 4 +-- .../lib_protocol/ticket_balance_key.ml | 2 +- .../lib_protocol/ticket_scanner.ml | 4 +-- .../lib_protocol/ticket_token_unparser.ml | 3 +-- 14 files changed, 46 insertions(+), 69 deletions(-) diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index dea478dbd21f..dc76eedf8b96 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -160,9 +160,13 @@ module Proto = struct assert (consumed > 0) ; consumed - let unparse_ty (_raw_ctxt : Raw_context.t) (Ex_ty ty) = - wrap_tzresult @@ Gas_monad.run_unaccounted - @@ Script_ir_unparser.unparse_ty ~loc:0 ty + let unparse_ty (raw_ctxt : Raw_context.t) (Ex_ty ty) = + let open Result_syntax in + let ctxt : Alpha_context.context = Obj.magic raw_ctxt in + let+ expr, _ = + wrap_tzresult @@ Script_ir_unparser.unparse_ty ~loc:0 ctxt ty + in + expr let parse_toplevel (raw_ctxt : Raw_context.t) expr = let open Lwt_result_syntax in @@ -287,11 +291,9 @@ module Proto = struct match parse_result with | Error _ -> acc | Ok (data, _cost) -> ( - match - Gas_monad.run_unaccounted @@ Script_ir_unparser.unparse_ty ~loc:0 ty - with + match Script_ir_unparser.unparse_ty ~loc:0 (Obj.magic ctxt) ty with | Error _ -> assert false - | Ok ty_expr -> + | Ok (ty_expr, _) -> List.fold_left (fun acc g -> f acc ty_expr @@ g data) acc getters) end diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 613bf75b3c76..6668d9eabce6 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -734,8 +734,7 @@ let parse_ty ctxt node = ~allow_ticket:true node -let unparse_ty ctxt ty = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:(-1) ty +let unparse_ty ctxt ty = Script_ir_unparser.unparse_ty ~loc:(-1) ctxt ty module Parse_type_benchmark : Benchmark.S = struct include Parse_type_shared diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index af9fed1a9a48..5bc3ce138db7 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -854,9 +854,7 @@ module Scripts = struct match (sty, x, st) with | Bot_t, EmptyCell, EmptyCell -> return ([], ctxt) | Item_t (ty, sty), x, (y, st) -> - let*? ty_node, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc ty - in + let*? ty_node, ctxt = Script_ir_unparser.unparse_ty ~loc ctxt ty in let* data_node, ctxt = Script_ir_translator.unparse_data ctxt unparsing_mode ty x in diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 363002a8c6ed..ea449e8f7512 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -565,8 +565,7 @@ let register () = | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> if normalize_types then let*? ty_node, _ctxt = - Gas_monad.run_pure ctxt - @@ Script_ir_unparser.unparse_ty ~loc:() ty + Script_ir_unparser.unparse_ty ~loc:() ctxt ty in return_some (Micheline.strip_locations ty_node) else @@ -612,8 +611,7 @@ let register () = let* ty_expr, ctxt = if normalize_types then let* ty_node, ctxt = - Gas_monad.run_pure ctxt - @@ Script_ir_unparser.unparse_ty ~loc:() ty + Script_ir_unparser.unparse_ty ~loc:() ctxt ty in return (Micheline.strip_locations ty_node, ctxt) else diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 0b176469fd6b..cfdad3f2c2a8 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -479,9 +479,7 @@ let apply ctxt gas capture_ty capture lam = let open Lwt_result_syntax in let loc = Micheline.dummy_location in let ctxt = update_context gas ctxt in - let*? ty_expr, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc capture_ty - in + let*? ty_expr, ctxt = Script_ir_unparser.unparse_ty ~loc ctxt capture_ty in let* const_expr, ctxt = unparse_data ctxt Optimized capture_ty capture in let make_expr expr = Micheline.( @@ -499,11 +497,10 @@ let apply ctxt gas capture_ty capture lam = in let (Item_t (ret_ty, Bot_t)) = descr.kaft in let*? arg_ty_expr, ctxt = - Gas_monad.run_pure ctxt - @@ Script_ir_unparser.unparse_ty ~loc full_arg_ty + Script_ir_unparser.unparse_ty ~loc ctxt full_arg_ty in let*? ret_ty_expr, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc ret_ty + Script_ir_unparser.unparse_ty ~loc ctxt ret_ty in match full_arg_ty with | Pair_t (capture_ty, arg_ty, _, _) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b19eadd8f4da..79d53aacb5f2 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -4547,9 +4547,7 @@ and parse_instr : | 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*? unparsed_ty, ctxt = unparse_ty ~loc:() ctxt data in let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed_ty) in let unparsed_ty = Micheline.strip_locations unparsed_ty in let instr = @@ -5309,26 +5307,17 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage let* arg_type, storage_type, views, ctxt = if normalize_types then let*? arg_type, ctxt = - Gas_monad.run_pure ctxt - @@ unparse_parameter_ty ~loc arg_type ~entrypoints - in - let*? storage_type, ctxt = - Gas_monad.run_pure ctxt @@ unparse_ty ~loc storage_type + unparse_parameter_ty ~loc ctxt arg_type ~entrypoints in + let*? storage_type, ctxt = unparse_ty ~loc ctxt storage_type in let+ views, ctxt = Script_map.map_es_in_context (fun ctxt _name (Typed_view {input_ty; output_ty; kinstr = _; original_code_expr}) -> - let*? (input_ty, output_ty), ctxt = - Gas_monad.run_pure - ctxt - (let open Gas_monad.Syntax in - let* input_ty = unparse_ty ~loc input_ty in - let+ output_ty = unparse_ty ~loc output_ty in - (input_ty, output_ty)) - in + let*? input_ty, ctxt = unparse_ty ~loc ctxt input_ty in + let*? output_ty, ctxt = unparse_ty ~loc ctxt output_ty in return ({input_ty; output_ty; view_code = original_code_expr}, ctxt)) ctxt typed_views @@ -5418,9 +5407,7 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy let* ctxt, id = Big_map.fresh ~temporary ctxt in let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost kt) in - let*? kv, ctxt = - Gas_monad.run_pure ctxt @@ unparse_ty ~loc:() value_type - in + let*? kv, ctxt = unparse_ty ~loc:() ctxt value_type in let*? ctxt = Gas.consume ctxt (Script.strip_locations_cost kv) in let key_type = Micheline.strip_locations kt in let value_type = Micheline.strip_locations kv in diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index e6da79823abd..8ab7dc86632b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -154,10 +154,10 @@ and unparse_comparable_ty_uncarbonated : let unparse_ty_uncarbonated ~loc ty = unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints -let unparse_ty ~loc ty = - let open Gas_monad.Syntax in - let+ () = Gas_monad.consume_gas (Unparse_costs.unparse_type ty) in - unparse_ty_uncarbonated ~loc ty +let unparse_ty ~loc ctxt ty = + let open Result_syntax in + let+ ctxt = Gas.consume ctxt (Unparse_costs.unparse_type ty) in + (unparse_ty_uncarbonated ~loc ty, ctxt) let unparse_parameter_ty ~loc ctxt ty ~entrypoints = let open Result_syntax in diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index f6c0cae1872f..82747ff5c6d9 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -51,10 +51,13 @@ val serialize_ty_for_error : ('a, 'b) ty -> Script.expr in [ctxt]. Otherwise returns an empty list. *) val serialize_stack_for_error : context -> ('a, 'b) stack_ty -> Script.expr list -(** [unparse_ty ~loc ty] returns the Micheline representation of a given - type. *) +(** [unparse_ty ~loc ctxt ty] returns the Micheline representation of a given + type and an update context, where gas has been properly consumed. *) val unparse_ty : - loc:'loc -> ('b, 'c) ty -> ('loc Script.michelson_node, 'trace) Gas_monad.t + loc:'loc -> + context -> + ('b, 'c) ty -> + ('loc Script.michelson_node * context, error trace) result (** [unparse_comparable_ty_uncarbonated ~loc ty] returns the Michelson representation of comparable type [ty] without consuming gas. *) 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 f2be1305e0fe..bf903aa2e3e8 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 @@ -214,12 +214,15 @@ let setup ctxt ~key_type ~value_type entries = (List.map (fun (k, v) -> (k, Some v)) entries) in let*? key_type_node, ctxt = - Environment.wrap_tzresult @@ Gas_monad.run_pure ctxt - @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location key_type + Environment.wrap_tzresult + @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt key_type in let*? value_type_node, ctxt = - Environment.wrap_tzresult @@ Gas_monad.run_pure ctxt - @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location value_type + Environment.wrap_tzresult + @@ Script_ir_unparser.unparse_ty + ~loc:Micheline.dummy_location + ctxt + value_type in let key_type = Micheline.strip_locations key_type_node in let value_type = Micheline.strip_locations value_type_node in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 990cbd765147..790ae05ae0e0 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -117,7 +117,7 @@ let test_context_with_nat_nat_big_map ?(sc_rollup_enable = false) () = let*@ ctxt, id = Big_map.fresh ~temporary:false ctxt in let nat_ty = Script_typed_ir.nat_t in let*?@ nat_ty_node, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:() nat_ty + Script_ir_unparser.unparse_ty ctxt ~loc:() nat_ty in let nat_ty_expr = Micheline.strip_locations nat_ty_node in let alloc = Big_map.{key_type = nat_ty_expr; value_type = nat_ty_expr} in @@ -315,9 +315,7 @@ let test_parse_comb_type () = let test_unparse_ty loc ctxt expected ty = let open Result_syntax in Environment.wrap_tzresult - (let* actual, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:() ty - in + (let* actual, ctxt = Script_ir_unparser.unparse_ty ctxt ~loc:() ty in if actual = expected then Ok ctxt else Alcotest.failf "Unexpected error: %s" loc) @@ -362,10 +360,7 @@ let test_unparse_comparable_ty loc ctxt expected ty = let open Script_typed_ir in Environment.wrap_tzresult (let* set_ty_ty = set_t (-1) ty in - let* actual, ctxt = - Gas_monad.run_pure ctxt - @@ Script_ir_unparser.unparse_ty ~loc:() set_ty_ty - in + let* actual, ctxt = Script_ir_unparser.unparse_ty ctxt ~loc:() set_ty_ty in if actual = Prim ((), T_set, [expected], []) then return ctxt else Alcotest.failf "Unexpected error: %s" loc) diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index 9ad7bcdc6617..90d0b24f8d1d 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -199,9 +199,7 @@ let ctxt = let unparse_comparable_ty ty = Micheline.strip_locations - (fst - (assert_ok - (Gas_monad.run_pure ctxt Script_ir_unparser.(unparse_ty ~loc:() ty)))) + (fst (assert_ok Script_ir_unparser.(unparse_ty ~loc:() ctxt ty))) let unparse_comparable_data ty x = fst (assert_return Script_ir_translator.(unparse_data ctxt Readable ty x)) diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index 170e4136851a..9d649afba8d2 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -68,7 +68,7 @@ let of_ex_token ctxt ~owner let open Lwt_result_syntax in let loc = Micheline.dummy_location in let*? cont_ty_unstripped, ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc contents_type + Script_ir_unparser.unparse_ty ~loc ctxt contents_type in (* We strip the annotations from the content type in order to map tickets with the same content type, but with different annotations, to the diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index bacc7280a7a4..63fbcf553bf2 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -557,9 +557,7 @@ let ex_ticket_size ctxt (Ex_ticket (ty, ticket)) = (* type *) let open Lwt_result_syntax in let*? ty = Script_typed_ir.ticket_t Micheline.dummy_location ty in - let*? ty', ctxt = - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:() ty - in + let*? ty', ctxt = Script_ir_unparser.unparse_ty ~loc:() ctxt ty in let ty_nodes, ty_size = Script_typed_ir_size.node_size ty' in let ty_size_cost = Script_typed_ir_size_costs.nodes_cost ~nodes:ty_nodes in let*? ctxt = Gas.consume ctxt ty_size_cost in diff --git a/src/proto_alpha/lib_protocol/ticket_token_unparser.ml b/src/proto_alpha/lib_protocol/ticket_token_unparser.ml index a993dce3c228..0d0a5ab55f73 100644 --- a/src/proto_alpha/lib_protocol/ticket_token_unparser.ml +++ b/src/proto_alpha/lib_protocol/ticket_token_unparser.ml @@ -41,8 +41,7 @@ let unparse ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) = unparse_comparable_data ctxt Optimized_legacy contents_type contents in let*? ty_unstripped, ctxt = - Gas_monad.run_pure ctxt - @@ unparse_ty ~loc:Micheline.dummy_location contents_type + unparse_ty ~loc:Micheline.dummy_location ctxt contents_type in let*? ctxt = Gas.consume ctxt (Script.strip_annotations_cost ty_unstripped) in let ty = Script.strip_annotations ty_unstripped in -- GitLab From 2671304ac680c52654b13a8ff5858437adcbf507 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:31 +0200 Subject: [PATCH 10/16] Revert "Proto/Gas monad: add run_unaccounted" This reverts commit 662106889ef30aae07005b18c5e12aa7fbb5eaed. --- src/proto_alpha/lib_protocol/gas_monad.ml | 7 ------- src/proto_alpha/lib_protocol/gas_monad.mli | 4 ---- 2 files changed, 11 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index f7908a3637e0..946f90184c78 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -93,13 +93,6 @@ let run ctxt m = let ctxt = update_context new_gas_counter outdated_ctxt in (res, ctxt) -let run_unaccounted (m : ('a, error trace) t) : 'a tzresult = - let open Result_syntax in - let* res, _new_gas_counter = - run_on_gas_counter Local_gas_counter.max_gas_counter m - in - res - type no_error = | let run_pure ctxt (m : ('a, no_error) t) : ('a * context) tzresult = diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index 18a2e6cc6534..7b150a94a7c9 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -75,10 +75,6 @@ val run_pure : ('a, no_error) t -> ('a * Alpha_context.context) tzresult -(** [run_unaccounted m] is a context-free variant of [run] in which - gas consumptions are ignored. *) -val run_unaccounted : ('a, error trace) t -> 'a tzresult - (** [record_trace_level ~error_details f m] returns a new gas-monad value that when run, records trace levels using [f]. This function has no effect in the case of a gas-exhaustion error or if [error_details] is [Fast]. *) -- GitLab From 5e3fca35d283d6331ee82fd0d221fa42e93daacb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:34 +0200 Subject: [PATCH 11/16] Revert "Proto/Gas monad: name the max gas counter" This reverts commit 80dab396be7d35ef5acad0d0b83839b89ee45e4c. --- src/proto_alpha/lib_protocol/gas_monad.ml | 4 +++- src/proto_alpha/lib_protocol/local_gas_counter.ml | 2 -- src/proto_alpha/lib_protocol/local_gas_counter.mli | 5 ----- 3 files changed, 3 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 946f90184c78..9e71427a89df 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -82,7 +82,9 @@ let run ctxt m = match Gas.level ctxt with | Gas.Unaccounted -> let+ res, _new_gas_counter = - run_on_gas_counter Local_gas_counter.max_gas_counter m + run_on_gas_counter + (Local_gas_counter (Saturation_repr.saturated :> int)) + m in (res, ctxt) | Limited {remaining = _} -> diff --git a/src/proto_alpha/lib_protocol/local_gas_counter.ml b/src/proto_alpha/lib_protocol/local_gas_counter.ml index 6aca1f4f0ce4..5a7da2dcc375 100644 --- a/src/proto_alpha/lib_protocol/local_gas_counter.ml +++ b/src/proto_alpha/lib_protocol/local_gas_counter.ml @@ -46,8 +46,6 @@ open Alpha_context type local_gas_counter = Local_gas_counter of int [@@ocaml.unboxed] -let max_gas_counter = Local_gas_counter max_int - (* The gas counter stored in the context is de-synchronized with the diff --git a/src/proto_alpha/lib_protocol/local_gas_counter.mli b/src/proto_alpha/lib_protocol/local_gas_counter.mli index 8a98be10d0ac..0f2555eab36a 100644 --- a/src/proto_alpha/lib_protocol/local_gas_counter.mli +++ b/src/proto_alpha/lib_protocol/local_gas_counter.mli @@ -30,11 +30,6 @@ (** A [local_gas_counter] is a wrapped [int]. *) type local_gas_counter = Local_gas_counter of int [@@ocaml.unboxed] -(** Maximum value that the gas counter can take. This is orders of - magnitude larger than block gas limit so it should only be used in - unaccounted gas mode. *) -val max_gas_counter : local_gas_counter - (** A type for describing a context that is not up to date with respect to gas consumption. *) type outdated_context -- GitLab From f71d3bcf98ae625ddd4e4e59922669000f7d9d74 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:36 +0200 Subject: [PATCH 12/16] Revert "Proto/Gas monad: factorize branches of run" This reverts commit 0d3358223c81758403636391158e5187d02ed141. --- src/proto_alpha/lib_protocol/gas_monad.ml | 27 +++++++++-------------- 1 file changed, 10 insertions(+), 17 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 9e71427a89df..c02f9098064c 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -70,30 +70,23 @@ let consume_gas cost gas = | None -> None | Some gas -> Some (Ok (), gas) -let run_on_gas_counter gas_counter m = - let open Result_syntax in - match m gas_counter with - | Some (res, new_gas_counter) -> return (res, new_gas_counter) - | None -> tzfail Gas.Operation_quota_exceeded - let run ctxt m = let open Local_gas_counter in let open Result_syntax in match Gas.level ctxt with - | Gas.Unaccounted -> - let+ res, _new_gas_counter = - run_on_gas_counter - (Local_gas_counter (Saturation_repr.saturated :> int)) - m - in - (res, ctxt) - | Limited {remaining = _} -> + | Gas.Unaccounted -> ( + match m (Local_gas_counter (Saturation_repr.saturated :> int)) with + | Some (res, _new_gas_counter) -> return (res, ctxt) + | None -> tzfail Gas.Operation_quota_exceeded) + | Limited {remaining = _} -> ( let gas_counter, outdated_ctxt = local_gas_counter_and_outdated_context ctxt in - let+ res, new_gas_counter = run_on_gas_counter gas_counter m in - let ctxt = update_context new_gas_counter outdated_ctxt in - (res, ctxt) + match m gas_counter with + | Some (res, new_gas_counter) -> + let ctxt = update_context new_gas_counter outdated_ctxt in + return (res, ctxt) + | None -> tzfail Gas.Operation_quota_exceeded) type no_error = | -- GitLab From c7825253c8572501e0400a2e32e19bdf5cfe997a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:37 +0200 Subject: [PATCH 13/16] Revert "Proto/Gas monad: add `let+?`" This reverts commit d09cede10fa6d5439673872705dd912019c8d985. --- src/proto_alpha/lib_protocol/gas_monad.ml | 4 ---- src/proto_alpha/lib_protocol/gas_monad.mli | 4 ---- 2 files changed, 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index c02f9098064c..7d4f96d519e0 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -60,8 +60,6 @@ let map f m gas = let bind_result m f = bind (of_result m) f [@@ocaml.inline always] -let map_result f m = map f (of_result m) [@@ocaml.inline always] - let bind_recover m f gas = m gas >>?? fun (x, gas) -> f x gas [@@ocaml.inline always] @@ -137,6 +135,4 @@ module Syntax = struct let ( let+ ) m f = map f m let ( let*? ) = bind_result - - let ( let+? ) m f = map_result f m end diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index 7b150a94a7c9..630b4e6fef64 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -132,8 +132,4 @@ module Syntax : sig gas-monad. *) val ( let*? ) : ('a, 'trace) result -> ('a -> ('b, 'trace) t) -> ('b, 'trace) t - - (** [let+?] is for mapping the value from result-only expressions into the - gas-monad. *) - val ( let+? ) : ('a, 'trace) result -> ('a -> 'b) -> ('b, 'trace) t end -- GitLab From 25634bdd6ea3e4b16162e7b50f0e48305d8c18cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:38 +0200 Subject: [PATCH 14/16] Revert "Proto/Gas monad: add `tzfail`" This reverts commit 6cadeb8b2fde841203cfc960d2807e105bf52ea1. --- src/proto_alpha/lib_protocol/gas_monad.ml | 4 ---- src/proto_alpha/lib_protocol/gas_monad.mli | 6 ------ .../lib_protocol/test/unit/test_gas_monad.ml | 16 ++++++++++++---- 3 files changed, 12 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 7d4f96d519e0..89b16416c993 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -109,8 +109,6 @@ let record_trace_eval : let fail e = of_result (Error e) [@@ocaml.inline always] -let tzfail e = of_result (Result_syntax.tzfail e) [@@ocaml.inline always] - module Syntax = struct let return = return @@ -128,8 +126,6 @@ module Syntax = struct let fail = fail - let tzfail = tzfail - let ( let* ) = bind let ( let+ ) m f = map f m diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index 630b4e6fef64..e9464558f1c6 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -87,9 +87,6 @@ val record_trace_eval : (** [fail e] is [of_result (Error e)] . *) val fail : 'trace -> ('a, 'trace) t -(** [tzfail e] is [of_result (Result_syntax.tzfail e)] . *) -val tzfail : 'err -> ('a, 'err Error_monad.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} @@ -119,9 +116,6 @@ module Syntax : sig (** [fail e] is [of_result (Error e)] . *) val fail : 'trace -> ('a, 'trace) t - (** [tzfail e] is [of_result (Result_syntax.tzfail e)] . *) - val tzfail : 'err -> ('a, 'err Error_monad.trace) t - (** [let*] is a binding operator alias for {!bind}. *) val ( let* ) : ('a, 'trace) t -> ('a -> ('b, 'trace) t) -> ('b, 'trace) t diff --git a/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml b/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml index 10dfad53a59b..2f76119c0889 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_gas_monad.ml @@ -55,7 +55,15 @@ let assert_inner_errors ~loc ctxt gas_monad ~errors ~remaining_gas = let open Lwt_result_syntax in match GM.run ctxt gas_monad with | Ok (Error e, ctxt) -> - let* () = Assert.equal_string ~loc e errors in + let* () = + Assert.assert_equal_list + ~loc + ( = ) + "Inner error" + Format.pp_print_string + e + errors + in assert_equal_gas ~loc (Gas.remaining_operation_gas ctxt) @@ -101,7 +109,7 @@ let test_gas_exhaustion_before_error () = let* () = GM.consume_gas (Saturation_repr.safe_int 5) in let* x = GM.return 1 in let* () = GM.consume_gas (Saturation_repr.safe_int 10) in - let* () = GM.of_result (Error "Oh no") in + let* () = GM.of_result (error "Oh no") in let* y = GM.return 2 in GM.return (x + y) in @@ -141,7 +149,7 @@ let test_inner_error () = let open Gas_monad.Syntax in let* x = GM.return 1 in let* () = GM.consume_gas (Saturation_repr.safe_int 5) in - let* () = GM.of_result (Error "Oh no") in + let* () = GM.of_result (error "Oh no") in let* y = GM.return 2 in let* () = GM.consume_gas (Saturation_repr.safe_int 10) in GM.return (x + y) @@ -150,7 +158,7 @@ let test_inner_error () = ~loc:__LOC__ ctxt gas_monad - ~errors:"Oh no" + ~errors:["Oh no"] ~remaining_gas:5 (* Test that no gas-exhaustion error is produced and that no gas is consumed -- GitLab From 7133f3007260f7df0a656b2b1facd7c72f874557 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:39 +0200 Subject: [PATCH 15/16] Revert "Proto/Gas monad: add run_pure" This reverts commit aa6045fed7e2ea133a3f04c8fa80310f3d59d110. --- src/proto_alpha/lib_protocol/gas_monad.ml | 7 ------- src/proto_alpha/lib_protocol/gas_monad.mli | 9 --------- 2 files changed, 16 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 89b16416c993..2938a881e457 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -86,13 +86,6 @@ let run ctxt m = return (res, ctxt) | None -> tzfail Gas.Operation_quota_exceeded) -type no_error = | - -let run_pure ctxt (m : ('a, no_error) t) : ('a * context) tzresult = - let open Result_syntax in - let* res, ctxt = run ctxt m in - match res with Ok x -> return (x, ctxt) | Error _ -> . - let record_trace_eval : type error_trace error_context. error_details:(error_context, error_trace) Script_tc_errors.error_details -> diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index e9464558f1c6..80ddae7204fd 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -66,15 +66,6 @@ val run : ('a, 'trace) t -> (('a, 'trace) result * Alpha_context.context) tzresult -type no_error - -(** [run_pure ctxt m] is a variant of [run ctxt m] expecting [m] to - always succeed. *) -val run_pure : - Alpha_context.context -> - ('a, no_error) t -> - ('a * Alpha_context.context) tzresult - (** [record_trace_level ~error_details f m] returns a new gas-monad value that when run, records trace levels using [f]. This function has no effect in the case of a gas-exhaustion error or if [error_details] is [Fast]. *) -- GitLab From 3526bdc5983ce15d9f3edf64f69ef6406b4a5dbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Wed, 27 Sep 2023 15:14:40 +0200 Subject: [PATCH 16/16] Revert "Proto/Gas monad: fix docstring of `fail`" This reverts commit 2dfdd439779ad471d58c9a028ddf639f5161d4be. --- src/proto_alpha/lib_protocol/gas_monad.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index 80ddae7204fd..5ee666d3e049 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -75,7 +75,7 @@ val record_trace_eval : ('a, 'error_trace) t -> ('a, 'error_trace) t -(** [fail e] is [of_result (Error e)] . *) +(** [fail e] is [return (Error e)] . *) val fail : 'trace -> ('a, 'trace) t (** Syntax module for the {!Gas_monad}. This is intended to be opened locally in @@ -104,7 +104,7 @@ module Syntax : sig (** [return_false] is [return false] . *) val return_false : (bool, 'trace) t - (** [fail e] is [of_result (Error e)] . *) + (** [fail e] is [return (Error e)] . *) val fail : 'trace -> ('a, 'trace) t (** [let*] is a binding operator alias for {!bind}. *) -- GitLab