From 86db49ed67e7b5c978f1310b2f87881ab3cbb16c Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 13 Oct 2021 18:18:06 +0200 Subject: [PATCH 01/24] Proto: use Script.location rather than int --- .../lib_protocol/script_interpreter_defs.ml | 2 +- .../lib_protocol/script_ir_annot.ml | 34 +++++++++++------- .../lib_protocol/script_ir_annot.mli | 35 ++++++++++++------- .../lib_protocol/script_ir_translator.ml | 4 +-- .../lib_protocol/script_ir_translator.mli | 2 +- .../lib_protocol/script_tc_errors.ml | 2 +- .../test/helpers/test_global_constants.ml | 2 +- 7 files changed, 51 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 718b0dcfedfa..11d9dea8bef5 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -946,7 +946,7 @@ type ('a, 'b) ifailwith_type = logger option -> outdated_context * step_constants -> local_gas_counter -> - int -> + Script.location -> 'a ty -> 'a -> ('b, error trace) result Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 689f9e8668f1..62b996b64418 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -286,14 +286,17 @@ let get_two_annot loc = function | [a; b] -> ok (a, b) | _ -> error (Unexpected_annotation loc) -let parse_type_annot : int -> string list -> type_annot option tzresult = +let parse_type_annot : + Script.location -> string list -> type_annot option tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc vars >>? fun () -> error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types let parse_type_field_annot : - int -> string list -> (type_annot option * field_annot option) tzresult = + Script.location -> + string list -> + (type_annot option * field_annot option) tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc vars >>? fun () -> @@ -301,7 +304,7 @@ let parse_type_field_annot : get_one_annot loc fields >|? fun f -> (t, f) let parse_composed_type_annot : - int -> + Script.location -> string list -> (type_annot option * field_annot option * field_annot option) tzresult = fun loc annot -> @@ -310,7 +313,8 @@ let parse_composed_type_annot : get_one_annot loc types >>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2) -let parse_field_annot : int -> string list -> field_annot option tzresult = +let parse_field_annot : + Script.location -> string list -> field_annot option tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc vars >>? fun () -> @@ -343,8 +347,10 @@ let check_correct_field : else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2)) let parse_var_annot : - int -> ?default:var_annot option -> string list -> var_annot option tzresult - = + Script.location -> + ?default:var_annot option -> + string list -> + var_annot option tzresult = fun loc ?default annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc types >>? fun () -> @@ -378,7 +384,7 @@ let common_prefix v1 v2 = | (_, _) -> None let parse_constr_annot : - int -> + Script.location -> ?if_special_first:field_annot option -> ?if_special_second:field_annot option -> string list -> @@ -409,7 +415,9 @@ let parse_constr_annot : (v, t, f1, f2) let parse_two_var_annot : - int -> string list -> (var_annot option * var_annot option) tzresult = + Script.location -> + string list -> + (var_annot option * var_annot option) tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc types >>? fun () -> @@ -429,7 +437,7 @@ let var_annot_from_special : | None -> value_annot let parse_destr_annot : - int -> + Script.location -> string list -> default_accessor:field_annot option -> field_name:field_annot option -> @@ -449,7 +457,7 @@ let parse_destr_annot : (v, f) let parse_unpair_annot : - int -> + Script.location -> string list -> field_name_car:field_annot option -> field_name_cdr:field_annot option -> @@ -496,7 +504,7 @@ let parse_unpair_annot : (vcar, vcdr, fcar, fcdr) let parse_entrypoint_annot : - int -> + Script.location -> ?default:var_annot option -> string list -> (var_annot option * field_annot option) tzresult = @@ -509,7 +517,9 @@ let parse_entrypoint_annot : | None -> ( match default with Some a -> (a, f) | None -> (None, f)) let parse_var_type_annot : - int -> string list -> (var_annot option * type_annot option) tzresult = + Script.location -> + string list -> + (var_annot option * type_annot option) tzresult = fun loc annot -> parse_annots loc annot >>? classify_annot loc >>? fun (vars, types, fields) -> error_unexpected_annot loc fields >>? fun () -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 63f3ad0c6b02..c19a8389309c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -134,23 +134,27 @@ val merge_field_annot : val merge_var_annot : var_annot option -> var_annot option -> var_annot option (** @return an error {!Unexpected_annotation} in the monad the list is not empty. *) -val error_unexpected_annot : int -> 'a list -> unit tzresult +val error_unexpected_annot : Script.location -> 'a list -> unit tzresult (** Parse a type annotation only. *) -val parse_type_annot : int -> string list -> type_annot option tzresult +val parse_type_annot : + Script.location -> string list -> type_annot option tzresult (** Parse a field annotation only. *) -val parse_field_annot : int -> string list -> field_annot option tzresult +val parse_field_annot : + Script.location -> string list -> field_annot option tzresult (** Parse an annotation for composed types, of the form [:ty_name %field] in any order. *) val parse_type_field_annot : - int -> string list -> (type_annot option * field_annot option) tzresult + Script.location -> + string list -> + (type_annot option * field_annot option) tzresult (** Parse an annotation for composed types, of the form [:ty_name %field1 %field2] in any order. *) val parse_composed_type_annot : - int -> + Script.location -> string list -> (type_annot option * field_annot option * field_annot option) tzresult @@ -166,12 +170,15 @@ val check_correct_field : (** Parse a variable annotation, replaced by a default value if [None]. *) val parse_var_annot : - int -> ?default:var_annot option -> string list -> var_annot option tzresult + Script.location -> + ?default:var_annot option -> + string list -> + var_annot option tzresult val is_allowed_char : char -> bool val parse_constr_annot : - int -> + Script.location -> ?if_special_first:field_annot option -> ?if_special_second:field_annot option -> string list -> @@ -182,10 +189,12 @@ val parse_constr_annot : tzresult val parse_two_var_annot : - int -> string list -> (var_annot option * var_annot option) tzresult + Script.location -> + string list -> + (var_annot option * var_annot option) tzresult val parse_destr_annot : - int -> + Script.location -> string list -> default_accessor:field_annot option -> field_name:field_annot option -> @@ -194,7 +203,7 @@ val parse_destr_annot : (var_annot option * field_annot option) tzresult val parse_unpair_annot : - int -> + Script.location -> string list -> field_name_car:field_annot option -> field_name_cdr:field_annot option -> @@ -208,10 +217,12 @@ val parse_unpair_annot : tzresult val parse_entrypoint_annot : - int -> + Script.location -> ?default:var_annot option -> string list -> (var_annot option * field_annot option) tzresult val parse_var_type_annot : - int -> string list -> (var_annot option * type_annot option) tzresult + Script.location -> + string list -> + (var_annot option * type_annot option) tzresult diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 5c7378520e42..a5aeffb385e8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -107,7 +107,7 @@ type tc_context = type unparsing_mode = Optimized | Readable | Optimized_legacy type type_logger = - int -> + Script.location -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit @@ -1212,7 +1212,7 @@ let merge_branches : type a s b u c v. legacy:bool -> context -> - int -> + Script.location -> (a, s) judgement -> (b, u) judgement -> (a, s, b, u, c, v) branch -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 6e930c8b36bc..c5509fd5b023 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -163,7 +163,7 @@ module Gas_monad : sig end type type_logger = - int -> + Script.location -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index 1abe59e2e508..d71b9804dff2 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -32,7 +32,7 @@ type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind type unparsed_stack_ty = (Script.expr * Script.annot) list -type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list +type type_map = (Script.location * (unparsed_stack_ty * unparsed_stack_ty)) list (* Structure errors *) type error += Invalid_arity of Script.location * prim * int * int diff --git a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml index 84039ceeb4ff..5cf45883c2be 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml @@ -252,7 +252,7 @@ module Generators = struct () let rec replace_with_constant : - Script.node -> int -> Script.node * Script.node option = + Script.node -> Script.location -> Script.node * Script.node option = fun node loc -> let open Michelson_v1_primitives in let open Micheline in -- GitLab From 2d8e420959227623b5fc0354ef956d7e6b55d7d3 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 13 Oct 2021 18:26:18 +0200 Subject: [PATCH 02/24] Proto/client: use Script.location rather than Micheline.canonical_location --- src/proto_alpha/lib_client/client_proto_fa12.ml | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index 6aabd72757c1..4d0e658460be 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -225,7 +225,7 @@ let () = expr) Data_encoding.( obj2 - (req "location" Tezos_micheline.Micheline.canonical_location_encoding) + (req "location" Script.location_encoding) (req "value" Script.expr_encoding)) (function Unexpected_error (loc, expr) -> Some (loc, expr) | _ -> None) (fun (loc, expr) -> Unexpected_error (loc, expr)) @@ -260,11 +260,7 @@ let callback ~loc ?entrypoint addr = (** Michelson type combinators: produce a Michelson node of the expected type, and a function to check another node is syntactically equivalent. *) - -type node = - (Micheline.canonical_location, Michelson_v1_primitives.prim) Micheline.node - -type type_eq_combinator = node * (node -> bool) +type type_eq_combinator = Script.node * (Script.node -> bool) (** [t_pair ~loc l] takes a list of types and respective equivalence check functions, and returns a type of n-ary pair of such types and -- GitLab From 201169888be64b05ea9833bec68166869edcd426 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 13 Oct 2021 19:28:27 +0200 Subject: [PATCH 03/24] Proto: generalize location in unparse_ty --- .../translator_benchmarks.ml | 2 +- src/proto_alpha/lib_plugin/plugin.ml | 102 ++++++++------- .../lib_protocol/alpha_context.mli | 2 +- .../lib_protocol/contract_services.ml | 2 +- .../lib_protocol/script_interpreter_defs.ml | 7 +- .../lib_protocol/script_ir_translator.ml | 120 ++++++++++-------- .../lib_protocol/script_ir_translator.mli | 9 +- src/proto_alpha/lib_protocol/script_repr.mli | 3 +- .../test/test_script_comparison.ml | 3 +- .../test/test_script_typed_ir_size.ml | 2 +- .../lib_protocol/test/test_typechecking.ml | 8 +- 11 files changed, 141 insertions(+), 119 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index e30147d8831b..b6afb1f89145 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -671,7 +671,7 @@ let parse_ty ctxt node = ~allow_ticket:true node -let unparse_ty ctxt ty = Script_ir_translator.unparse_ty ctxt ty +let unparse_ty ctxt ty = Script_ir_translator.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/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 8ed22f5b5e0a..4e6230a1b90b 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -964,50 +964,56 @@ module RPC = struct open Script_ir_annot open Script_typed_ir - let rec unparse_comparable_ty : type a. a comparable_ty -> Script.node = - function - | Unit_key meta -> Prim (-1, T_unit, [], unparse_type_annot meta.annot) - | Never_key meta -> Prim (-1, T_never, [], unparse_type_annot meta.annot) - | Int_key meta -> Prim (-1, T_int, [], unparse_type_annot meta.annot) - | Nat_key meta -> Prim (-1, T_nat, [], unparse_type_annot meta.annot) + let rec unparse_comparable_ty : + type a loc. + loc:loc -> a comparable_ty -> (loc, Script.prim) Micheline.node = + fun ~loc -> function + | Unit_key meta -> Prim (loc, T_unit, [], unparse_type_annot meta.annot) + | Never_key meta -> + Prim (loc, T_never, [], unparse_type_annot meta.annot) + | Int_key meta -> Prim (loc, T_int, [], unparse_type_annot meta.annot) + | Nat_key meta -> Prim (loc, T_nat, [], unparse_type_annot meta.annot) | Signature_key meta -> - Prim (-1, T_signature, [], unparse_type_annot meta.annot) + Prim (loc, T_signature, [], unparse_type_annot meta.annot) | String_key meta -> - Prim (-1, T_string, [], unparse_type_annot meta.annot) - | Bytes_key meta -> Prim (-1, T_bytes, [], unparse_type_annot meta.annot) - | Mutez_key meta -> Prim (-1, T_mutez, [], unparse_type_annot meta.annot) - | Bool_key meta -> Prim (-1, T_bool, [], unparse_type_annot meta.annot) + Prim (loc, T_string, [], unparse_type_annot meta.annot) + | Bytes_key meta -> + Prim (loc, T_bytes, [], unparse_type_annot meta.annot) + | Mutez_key meta -> + Prim (loc, T_mutez, [], unparse_type_annot meta.annot) + | Bool_key meta -> Prim (loc, T_bool, [], unparse_type_annot meta.annot) | Key_hash_key meta -> - Prim (-1, T_key_hash, [], unparse_type_annot meta.annot) - | Key_key meta -> Prim (-1, T_key, [], unparse_type_annot meta.annot) + Prim (loc, T_key_hash, [], unparse_type_annot meta.annot) + | Key_key meta -> Prim (loc, T_key, [], unparse_type_annot meta.annot) | Timestamp_key meta -> - Prim (-1, T_timestamp, [], unparse_type_annot meta.annot) + Prim (loc, T_timestamp, [], unparse_type_annot meta.annot) | Address_key meta -> - Prim (-1, T_address, [], unparse_type_annot meta.annot) + Prim (loc, T_address, [], unparse_type_annot meta.annot) | Chain_id_key meta -> - Prim (-1, T_chain_id, [], unparse_type_annot meta.annot) + Prim (loc, T_chain_id, [], unparse_type_annot meta.annot) | Pair_key ((l, al), (r, ar), meta) -> - let tl = add_field_annot al None (unparse_comparable_ty l) in - let tr = add_field_annot ar None (unparse_comparable_ty r) in - Prim (-1, T_pair, [tl; tr], unparse_type_annot meta.annot) + let tl = add_field_annot al None (unparse_comparable_ty ~loc l) in + let tr = add_field_annot ar None (unparse_comparable_ty ~loc r) in + Prim (loc, T_pair, [tl; tr], unparse_type_annot meta.annot) | Union_key ((l, al), (r, ar), meta) -> - let tl = add_field_annot al None (unparse_comparable_ty l) in - let tr = add_field_annot ar None (unparse_comparable_ty r) in - Prim (-1, T_or, [tl; tr], unparse_type_annot meta.annot) + let tl = add_field_annot al None (unparse_comparable_ty ~loc l) in + let tr = add_field_annot ar None (unparse_comparable_ty ~loc r) in + Prim (loc, T_or, [tl; tr], unparse_type_annot meta.annot) | Option_key (t, meta) -> Prim - ( -1, + ( loc, T_option, - [unparse_comparable_ty t], + [unparse_comparable_ty ~loc t], unparse_type_annot meta.annot ) - let unparse_memo_size memo_size = + let unparse_memo_size ~loc memo_size = let z = Alpha_context.Sapling.Memo_size.unparse_to_z memo_size in - Int (-1, z) + Int (loc, z) - let rec unparse_ty : type a. a ty -> Script.node = - fun ty -> - let return (name, args, annot) = Prim (-1, name, args, annot) in + let rec unparse_ty : + type a loc. loc:loc -> a ty -> (loc, Script.prim) Micheline.node = + fun ~loc ty -> + let return (name, args, annot) = Prim (loc, name, args, annot) in match ty with | Unit_t meta -> return (T_unit, [], unparse_type_annot meta.annot) | Int_t meta -> return (T_int, [], unparse_type_annot meta.annot) @@ -1036,56 +1042,56 @@ module RPC = struct | Bls12_381_fr_t meta -> return (T_bls12_381_fr, [], unparse_type_annot meta.annot) | Contract_t (ut, meta) -> - let t = unparse_ty ut in + let t = unparse_ty ~loc ut in return (T_contract, [t], unparse_type_annot meta.annot) | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), meta) -> let annot = unparse_type_annot meta.annot in - let utl = unparse_ty utl in + let utl = unparse_ty ~loc utl in let tl = add_field_annot l_field l_var utl in - let utr = unparse_ty utr in + let utr = unparse_ty ~loc utr in let tr = add_field_annot r_field r_var utr in return (T_pair, [tl; tr], annot) | Union_t ((utl, l_field), (utr, r_field), meta) -> let annot = unparse_type_annot meta.annot in - let utl = unparse_ty utl in + let utl = unparse_ty ~loc utl in let tl = add_field_annot l_field None utl in - let utr = unparse_ty utr in + let utr = unparse_ty ~loc utr in let tr = add_field_annot r_field None utr in return (T_or, [tl; tr], annot) | Lambda_t (uta, utr, meta) -> - let ta = unparse_ty uta in - let tr = unparse_ty utr in + let ta = unparse_ty ~loc uta in + let tr = unparse_ty ~loc utr in return (T_lambda, [ta; tr], unparse_type_annot meta.annot) | Option_t (ut, meta) -> let annot = unparse_type_annot meta.annot in - let ut = unparse_ty ut in + let ut = unparse_ty ~loc ut in return (T_option, [ut], annot) | List_t (ut, meta) -> - let t = unparse_ty ut in + let t = unparse_ty ~loc ut in return (T_list, [t], unparse_type_annot meta.annot) | Ticket_t (ut, meta) -> - let t = unparse_comparable_ty ut in + let t = unparse_comparable_ty ~loc ut in return (T_ticket, [t], unparse_type_annot meta.annot) | Set_t (ut, meta) -> - let t = unparse_comparable_ty ut in + let t = unparse_comparable_ty ~loc ut in return (T_set, [t], unparse_type_annot meta.annot) | Map_t (uta, utr, meta) -> - let ta = unparse_comparable_ty uta in - let tr = unparse_ty utr in + let ta = unparse_comparable_ty ~loc uta in + let tr = unparse_ty ~loc utr in return (T_map, [ta; tr], unparse_type_annot meta.annot) | Big_map_t (uta, utr, meta) -> - let ta = unparse_comparable_ty uta in - let tr = unparse_ty utr in + let ta = unparse_comparable_ty ~loc uta in + let tr = unparse_ty ~loc utr in return (T_big_map, [ta; tr], unparse_type_annot meta.annot) | Sapling_transaction_t (memo_size, meta) -> return ( T_sapling_transaction, - [unparse_memo_size memo_size], + [unparse_memo_size ~loc memo_size], unparse_type_annot meta.annot ) | Sapling_state_t (memo_size, meta) -> return ( T_sapling_state, - [unparse_memo_size memo_size], + [unparse_memo_size ~loc memo_size], unparse_type_annot meta.annot ) | Chest_t meta -> return (T_chest, [], unparse_type_annot meta.annot) | Chest_key_t meta -> @@ -1243,7 +1249,7 @@ module RPC = struct arg_type entrypoint ) >>? fun (_f, Ex_ty ty) -> - unparse_ty ctxt ty >|? fun (ty_node, _) -> + unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _) -> Micheline.strip_locations ty_node ) in Registration.register0 @@ -1552,7 +1558,7 @@ module RPC = struct ~allow_ticket:true (Micheline.root typ) >>?= fun (Ex_ty typ, _ctxt) -> - let normalized = Unparse_types.unparse_ty typ in + let normalized = Unparse_types.unparse_ty ~loc:() typ in return @@ Micheline.strip_locations normalized) ; Registration.register0 ~chunked:true S.run_operation run_operation_service ; Registration.register0 diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 39bb91900b60..804ff73a453b 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -553,7 +553,7 @@ module Script : sig val unit_parameter : lazy_expr - val strip_locations_cost : node -> Gas.cost + val strip_locations_cost : (_, prim) Micheline.node -> Gas.cost end module Constants : sig diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index ff4c18ce6e75..b9d8c3ca7256 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -368,7 +368,7 @@ let[@coq_axiom_with_reason "gadt"] register () = entrypoint ) |> function | Ok (_f, Ex_ty ty) -> - unparse_ty ctxt ty >|? fun (ty_node, _) -> + unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _) -> Some (Micheline.strip_locations ty_node) | Error _ -> Result.return_none )) ; opt_register1 ~chunked:true S.list_entrypoints (fun ctxt v () () -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 11d9dea8bef5..ecc67201fbae 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -568,7 +568,7 @@ let apply ctxt gas capture_ty capture lam = let (Item_t (full_arg_ty, _, _)) = descr.kbef in let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> - unparse_ty ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + unparse_ty ~loc:(-1) ctxt capture_ty >>?= fun (ty_expr, ctxt) -> match full_arg_ty with | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _) -> let arg_stack_ty = Item_t (arg_ty, Bot_t, None) in @@ -649,11 +649,12 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = let create_contract (ctxt, sc) gas storage_type param_type code views root_name delegate credit init = let ctxt = update_context gas ctxt in - unparse_ty ctxt param_type >>?= fun (unparsed_param_type, ctxt) -> + unparse_ty ~loc:(-1) ctxt param_type >>?= fun (unparsed_param_type, ctxt) -> let unparsed_param_type = Script_ir_translator.add_field_annot root_name None unparsed_param_type in - unparse_ty ctxt storage_type >>?= fun (unparsed_storage_type, ctxt) -> + unparse_ty ~loc:(-1) ctxt storage_type + >>?= fun (unparsed_storage_type, ctxt) -> let open Micheline in let view name {input_ty; output_ty; view_code} views = Prim diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a5aeffb385e8..02f2aff1592d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -203,49 +203,57 @@ let add_field_annot a var = function (loc, prim, args, annots @ unparse_field_annot a @ unparse_var_annot var) | expr -> expr -let rec unparse_comparable_ty : type a. a comparable_ty -> Script.node = - function - | Unit_key meta -> Prim (-1, T_unit, [], unparse_type_annot meta.annot) - | Never_key meta -> Prim (-1, T_never, [], unparse_type_annot meta.annot) - | Int_key meta -> Prim (-1, T_int, [], unparse_type_annot meta.annot) - | Nat_key meta -> Prim (-1, T_nat, [], unparse_type_annot meta.annot) +let rec unparse_comparable_ty : + type a loc. loc:loc -> a comparable_ty -> (loc, Script.prim) Micheline.node + = + fun ~loc -> function + | Unit_key meta -> Prim (loc, T_unit, [], unparse_type_annot meta.annot) + | Never_key meta -> Prim (loc, T_never, [], unparse_type_annot meta.annot) + | Int_key meta -> Prim (loc, T_int, [], unparse_type_annot meta.annot) + | Nat_key meta -> Prim (loc, T_nat, [], unparse_type_annot meta.annot) | Signature_key meta -> - Prim (-1, T_signature, [], unparse_type_annot meta.annot) - | String_key meta -> Prim (-1, T_string, [], unparse_type_annot meta.annot) - | Bytes_key meta -> Prim (-1, T_bytes, [], unparse_type_annot meta.annot) - | Mutez_key meta -> Prim (-1, T_mutez, [], unparse_type_annot meta.annot) - | Bool_key meta -> Prim (-1, T_bool, [], unparse_type_annot meta.annot) - | Key_hash_key meta -> Prim (-1, T_key_hash, [], unparse_type_annot meta.annot) - | Key_key meta -> Prim (-1, T_key, [], unparse_type_annot meta.annot) + Prim (loc, T_signature, [], unparse_type_annot meta.annot) + | String_key meta -> Prim (loc, T_string, [], unparse_type_annot meta.annot) + | Bytes_key meta -> Prim (loc, T_bytes, [], unparse_type_annot meta.annot) + | Mutez_key meta -> Prim (loc, T_mutez, [], unparse_type_annot meta.annot) + | Bool_key meta -> Prim (loc, T_bool, [], unparse_type_annot meta.annot) + | Key_hash_key meta -> + Prim (loc, T_key_hash, [], unparse_type_annot meta.annot) + | Key_key meta -> Prim (loc, T_key, [], unparse_type_annot meta.annot) | Timestamp_key meta -> - Prim (-1, T_timestamp, [], unparse_type_annot meta.annot) - | Address_key meta -> Prim (-1, T_address, [], unparse_type_annot meta.annot) - | Chain_id_key meta -> Prim (-1, T_chain_id, [], unparse_type_annot meta.annot) + Prim (loc, T_timestamp, [], unparse_type_annot meta.annot) + | Address_key meta -> Prim (loc, T_address, [], unparse_type_annot meta.annot) + | Chain_id_key meta -> + Prim (loc, T_chain_id, [], unparse_type_annot meta.annot) | Pair_key ((l, al), (r, ar), meta) -> ( - let tl = add_field_annot al None (unparse_comparable_ty l) in - let tr = add_field_annot ar None (unparse_comparable_ty r) in + let tl = add_field_annot al None (unparse_comparable_ty ~loc l) in + let tr = add_field_annot ar None (unparse_comparable_ty ~loc r) in (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) (* Note that the folding does not happen if the pair on the right has a field annotation because this annotation would be lost *) match tr with | Prim (_, T_pair, ts, []) -> - Prim (-1, T_pair, tl :: ts, unparse_type_annot meta.annot) - | _ -> Prim (-1, T_pair, [tl; tr], unparse_type_annot meta.annot)) + Prim (loc, T_pair, tl :: ts, unparse_type_annot meta.annot) + | _ -> Prim (loc, T_pair, [tl; tr], unparse_type_annot meta.annot)) | Union_key ((l, al), (r, ar), meta) -> - let tl = add_field_annot al None (unparse_comparable_ty l) in - let tr = add_field_annot ar None (unparse_comparable_ty r) in - Prim (-1, T_or, [tl; tr], unparse_type_annot meta.annot) + let tl = add_field_annot al None (unparse_comparable_ty ~loc l) in + let tr = add_field_annot ar None (unparse_comparable_ty ~loc r) in + Prim (loc, T_or, [tl; tr], unparse_type_annot meta.annot) | Option_key (t, meta) -> Prim - (-1, T_option, [unparse_comparable_ty t], unparse_type_annot meta.annot) + ( loc, + T_option, + [unparse_comparable_ty ~loc t], + unparse_type_annot meta.annot ) -let unparse_memo_size memo_size = +let unparse_memo_size ~loc memo_size = let z = Sapling.Memo_size.unparse_to_z memo_size in - Int (-1, z) + Int (loc, z) -let rec unparse_ty_uncarbonated : type a. a ty -> Script.node = - fun ty -> - let prim (name, args, annot) = Prim (-1, name, args, annot) in +let rec unparse_ty_uncarbonated : + type a loc. loc:loc -> a ty -> (loc, Script.prim) Micheline.node = + fun ~loc ty -> + let prim (name, args, annot) = Prim (loc, name, args, annot) in match ty with | Unit_t meta -> prim (T_unit, [], unparse_type_annot meta.annot) | Int_t meta -> prim (T_int, [], unparse_type_annot meta.annot) @@ -269,13 +277,13 @@ let rec unparse_ty_uncarbonated : type a. a ty -> Script.node = | Bls12_381_fr_t meta -> prim (T_bls12_381_fr, [], unparse_type_annot meta.annot) | Contract_t (ut, meta) -> - let t = unparse_ty_uncarbonated ut in + let t = unparse_ty_uncarbonated ~loc ut in prim (T_contract, [t], unparse_type_annot meta.annot) | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), meta) -> let annot = unparse_type_annot meta.annot in - let utl = unparse_ty_uncarbonated utl in + let utl = unparse_ty_uncarbonated ~loc utl in let tl = add_field_annot l_field l_var utl in - let utr = unparse_ty_uncarbonated utr in + let utr = unparse_ty_uncarbonated ~loc utr in let tr = add_field_annot r_field r_var utr in (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) (* Note that the folding does not happen if the pair on the right has an @@ -286,52 +294,52 @@ let rec unparse_ty_uncarbonated : type a. a ty -> Script.node = | _ -> (T_pair, [tl; tr], annot)) | Union_t ((utl, l_field), (utr, r_field), meta) -> let annot = unparse_type_annot meta.annot in - let utl = unparse_ty_uncarbonated utl in + let utl = unparse_ty_uncarbonated ~loc utl in let tl = add_field_annot l_field None utl in - let utr = unparse_ty_uncarbonated utr in + let utr = unparse_ty_uncarbonated ~loc utr in let tr = add_field_annot r_field None utr in prim (T_or, [tl; tr], annot) | Lambda_t (uta, utr, meta) -> - let ta = unparse_ty_uncarbonated uta in - let tr = unparse_ty_uncarbonated utr in + let ta = unparse_ty_uncarbonated ~loc uta in + let tr = unparse_ty_uncarbonated ~loc utr in prim (T_lambda, [ta; tr], unparse_type_annot meta.annot) | Option_t (ut, meta) -> let annot = unparse_type_annot meta.annot in - let ut = unparse_ty_uncarbonated ut in + let ut = unparse_ty_uncarbonated ~loc ut in prim (T_option, [ut], annot) | List_t (ut, meta) -> - let t = unparse_ty_uncarbonated ut in + let t = unparse_ty_uncarbonated ~loc ut in prim (T_list, [t], unparse_type_annot meta.annot) | Ticket_t (ut, meta) -> - let t = unparse_comparable_ty ut in + let t = unparse_comparable_ty ~loc ut in prim (T_ticket, [t], unparse_type_annot meta.annot) | Set_t (ut, meta) -> - let t = unparse_comparable_ty ut in + let t = unparse_comparable_ty ~loc ut in prim (T_set, [t], unparse_type_annot meta.annot) | Map_t (uta, utr, meta) -> - let ta = unparse_comparable_ty uta in - let tr = unparse_ty_uncarbonated utr in + let ta = unparse_comparable_ty ~loc uta in + let tr = unparse_ty_uncarbonated ~loc utr in prim (T_map, [ta; tr], unparse_type_annot meta.annot) | Big_map_t (uta, utr, meta) -> - let ta = unparse_comparable_ty uta in - let tr = unparse_ty_uncarbonated utr in + let ta = unparse_comparable_ty ~loc uta in + let tr = unparse_ty_uncarbonated ~loc utr in prim (T_big_map, [ta; tr], unparse_type_annot meta.annot) | Sapling_transaction_t (memo_size, meta) -> prim ( T_sapling_transaction, - [unparse_memo_size memo_size], + [unparse_memo_size ~loc memo_size], unparse_type_annot meta.annot ) | Sapling_state_t (memo_size, meta) -> prim ( T_sapling_state, - [unparse_memo_size memo_size], + [unparse_memo_size ~loc memo_size], unparse_type_annot meta.annot ) | Chest_key_t meta -> prim (T_chest_key, [], unparse_type_annot meta.annot) | Chest_t meta -> prim (T_chest, [], unparse_type_annot meta.annot) -let unparse_ty ctxt ty = +let unparse_ty ~loc ctxt ty = Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> - (unparse_ty_uncarbonated ty, ctxt) + (unparse_ty_uncarbonated ~loc ty, ctxt) let[@coq_struct "function_parameter"] rec strip_var_annots = function | (Int _ | String _ | Bytes _) as atom -> atom @@ -342,7 +350,7 @@ let[@coq_struct "function_parameter"] rec strip_var_annots = function Prim (loc, name, List.map strip_var_annots args, annots) let serialize_ty_for_error ctxt ty = - unparse_ty ctxt ty + unparse_ty ~loc:() ctxt ty >>? (fun (ty, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost ty) >|? fun ctxt -> (Micheline.strip_locations (strip_var_annots ty), ctxt)) @@ -394,7 +402,7 @@ let rec unparse_stack : fun ctxt -> function | Bot_t -> ok ([], ctxt) | Item_t (ty, rest, annot) -> - unparse_ty ctxt ty >>? fun (uty, ctxt) -> + unparse_ty ~loc:() ctxt ty >>? fun (uty, ctxt) -> unparse_stack ctxt rest >|? fun (urest, ctxt) -> ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt) @@ -5907,7 +5915,7 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = else if Entrypoints_map.mem name all then ok (List.rev path :: unreachables, all) else - unparse_ty ctxt ty >>? fun (unparsed_ty, _) -> + unparse_ty ~loc:(-1) ctxt ty >>? fun (unparsed_ty, _) -> ok ( unreachables, Entrypoints_map.add name (List.rev path, unparsed_ty) all ) @@ -5937,7 +5945,7 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = acc | _ -> ok acc in - unparse_ty ctxt full >>? fun (unparsed_full, _) -> + unparse_ty ~loc:(-1) ctxt full >>? fun (unparsed_full, _) -> let (init, reachable) = match root_name with | None | Some (Field_annot "") -> (Entrypoints_map.empty, false) @@ -6204,8 +6212,8 @@ let unparse_script ctxt mode unparse_data ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> Lwt.return - ( unparse_ty ctxt arg_type >>? fun (arg_type, ctxt) -> - unparse_ty ctxt storage_type >>? fun (storage_type, ctxt) -> + ( unparse_ty ~loc:(-1) ctxt arg_type >>? fun (arg_type, ctxt) -> + unparse_ty ~loc:(-1) ctxt storage_type >>? fun (storage_type, ctxt) -> let arg_type = add_field_annot root_name None arg_type in let open Micheline in let view name {input_ty; output_ty; view_code} views = @@ -6344,9 +6352,9 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy | None -> Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> Lwt.return - (let kt = unparse_comparable_ty key_type in + (let kt = unparse_comparable_ty ~loc:() key_type in Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> - unparse_ty ctxt value_type >>? fun (kv, ctxt) -> + unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> 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_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index c5509fd5b023..32defe08bec2 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -326,7 +326,10 @@ val parse_ty : (ex_ty * context) tzresult val unparse_ty : - context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult + loc:'loc -> + context -> + 'a Script_typed_ir.ty -> + (('loc, Script.prim) Micheline.node * context) tzresult val ty_of_comparable_ty : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ty @@ -337,8 +340,8 @@ val parse_toplevel : val add_field_annot : Script_typed_ir.field_annot option -> Script_typed_ir.var_annot option -> - Script.node -> - Script.node + ('loc, 'prim) Micheline.node -> + ('loc, 'prim) Micheline.node val typecheck_code : legacy:bool -> context -> Script.expr -> (type_map * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_repr.mli b/src/proto_alpha/lib_protocol/script_repr.mli index 34d6a8305de8..a49753c66ad8 100644 --- a/src/proto_alpha/lib_protocol/script_repr.mli +++ b/src/proto_alpha/lib_protocol/script_repr.mli @@ -88,7 +88,8 @@ val is_unit_parameter : lazy_expr -> bool val strip_annotations : node -> node -val strip_locations_cost : node -> Gas_limit_repr.cost +val strip_locations_cost : + (_, Michelson_v1_primitives.prim) Micheline.node -> Gas_limit_repr.cost module Micheline_size : sig type t = { diff --git a/src/proto_alpha/lib_protocol/test/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/test_script_comparison.ml index 22fd1a82f2f7..4f33844788fb 100644 --- a/src/proto_alpha/lib_protocol/test/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/test_script_comparison.ml @@ -205,7 +205,8 @@ let unparse_comparable_ty ty = Micheline.strip_locations (fst (assert_ok - Script_ir_translator.(unparse_ty ctxt (ty_of_comparable_ty ty)))) + Script_ir_translator.( + unparse_ty ~loc:() ctxt (ty_of_comparable_ty ty)))) let unparse_comparable_data ty x = Micheline.strip_locations diff --git a/src/proto_alpha/lib_protocol/test/test_script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/test/test_script_typed_ir_size.ml index 5a80917cbe18..83cc3133495f 100644 --- a/src/proto_alpha/lib_protocol/test/test_script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/test/test_script_typed_ir_size.ml @@ -168,7 +168,7 @@ module Printers = struct string_of_something @@ fun ctxt -> Lwt.return @@ Script_ir_translator.( - unparse_ty ctxt ty >>? fun (node, _) -> + unparse_ty ~loc:() ctxt ty >>? fun (node, _) -> Ok (Micheline.strip_locations node)) let string_of_code code = string_of_something @@ fun _ -> return code diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index 6f5e257d109b..5c2a8068de17 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -73,7 +73,8 @@ let test_context_with_nat_nat_big_map () = let ctxt = Incremental.alpha_ctxt v in wrap_error_lwt @@ Big_map.fresh ~temporary:false ctxt >>=? fun (ctxt, id) -> let nat_ty = Script_typed_ir.nat_t ~annot:None in - wrap_error_lwt @@ Lwt.return @@ Script_ir_translator.unparse_ty ctxt nat_ty + wrap_error_lwt @@ Lwt.return + @@ Script_ir_translator.unparse_ty ~loc:() ctxt nat_ty >>=? fun (nat_ty_node, ctxt) -> 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 @@ -306,7 +307,7 @@ let test_parse_comb_type () = let test_unparse_ty loc ctxt expected ty = Environment.wrap_tzresult - ( Script_ir_translator.unparse_ty ctxt ty >>? fun (actual, ctxt) -> + ( Script_ir_translator.unparse_ty ~loc:(-1) ctxt ty >>? fun (actual, ctxt) -> if actual = expected then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) @@ -453,7 +454,8 @@ let test_unparse_comparable_ty loc ctxt expected ty = let open Script_typed_ir in Environment.wrap_tzresult ( set_t (-1) ty ~annot:None >>? fun set_ty_ty -> - Script_ir_translator.unparse_ty ctxt set_ty_ty >>? fun (actual, ctxt) -> + Script_ir_translator.unparse_ty ~loc:(-1) ctxt set_ty_ty + >>? fun (actual, ctxt) -> if actual = Prim (-1, T_set, [expected], []) then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) -- GitLab From 20ec23d69cf613fed4ea1dc62c844ef1fbb6e6f5 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 13 Oct 2021 20:00:25 +0200 Subject: [PATCH 04/24] Proto: generalize unparse_comparable_data location We can't do it for unparse_data because lambda nodes are embedded as is and we don't want to pay the price of converting them. Lambda nodes contain locations because they come from parsed expressions. --- .../lib_protocol/script_ir_translator.ml | 208 +++++++++--------- 1 file changed, 108 insertions(+), 100 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 02f2aff1592d..73451fc75691 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -443,30 +443,31 @@ let name_of_ty : type a. a ty -> type_annot option = function | Chest_key_t meta -> meta.annot | Chest_t meta -> meta.annot -let unparse_unit ctxt () = ok (Prim (-1, D_Unit, [], []), ctxt) +let unparse_unit ~loc ctxt () = ok (Prim (loc, D_Unit, [], []), ctxt) -let unparse_int ctxt v = ok (Int (-1, Script_int.to_zint v), ctxt) +let unparse_int ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) -let unparse_nat ctxt v = ok (Int (-1, Script_int.to_zint v), ctxt) +let unparse_nat ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) -let unparse_string ctxt s = ok (String (-1, Script_string.to_string s), ctxt) +let unparse_string ~loc ctxt s = + ok (String (loc, Script_string.to_string s), ctxt) -let unparse_bytes ctxt s = ok (Bytes (-1, s), ctxt) +let unparse_bytes ~loc ctxt s = ok (Bytes (loc, s), ctxt) -let unparse_bool ctxt b = - ok (Prim (-1, (if b then D_True else D_False), [], []), ctxt) +let unparse_bool ~loc ctxt b = + ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt) -let unparse_timestamp ctxt mode t = +let unparse_timestamp ~loc ctxt mode t = match mode with | Optimized | Optimized_legacy -> - ok (Int (-1, Script_timestamp.to_zint t), ctxt) + ok (Int (loc, Script_timestamp.to_zint t), ctxt) | Readable -> ( Gas.consume ctxt Unparse_costs.timestamp_readable >>? fun ctxt -> match Script_timestamp.to_notation t with - | None -> ok (Int (-1, Script_timestamp.to_zint t), ctxt) - | Some s -> ok (String (-1, s), ctxt)) + | None -> ok (Int (loc, Script_timestamp.to_zint t), ctxt) + | Some s -> ok (String (loc, s), ctxt)) -let unparse_address ctxt mode (c, entrypoint) = +let unparse_address ~loc ctxt mode (c, entrypoint) = Gas.consume ctxt Unparse_costs.contract >>? fun ctxt -> (match entrypoint with (* given parse_address, this should not happen *) @@ -481,92 +482,93 @@ let unparse_address ctxt mode (c, entrypoint) = Data_encoding.(tup2 Contract.encoding Variable.string) (c, entrypoint) in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) | Readable -> let notation = match entrypoint with | "default" -> Contract.to_b58check c | entrypoint -> Contract.to_b58check c ^ "%" ^ entrypoint in - (String (-1, notation), ctxt) + (String (loc, notation), ctxt) -let unparse_contract ctxt mode (_, address) = unparse_address ctxt mode address +let unparse_contract ~loc ctxt mode (_, address) = + unparse_address ~loc ctxt mode address -let unparse_signature ctxt mode s = +let unparse_signature ~loc ctxt mode s = match mode with | Optimized | Optimized_legacy -> Gas.consume ctxt Unparse_costs.signature_optimized >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) | Readable -> Gas.consume ctxt Unparse_costs.signature_readable >|? fun ctxt -> - (String (-1, Signature.to_b58check s), ctxt) + (String (loc, Signature.to_b58check s), ctxt) -let unparse_mutez ctxt v = ok (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) +let unparse_mutez ~loc ctxt v = ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt) -let unparse_key ctxt mode k = +let unparse_key ~loc ctxt mode k = match mode with | Optimized | Optimized_legacy -> Gas.consume ctxt Unparse_costs.public_key_optimized >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) | Readable -> Gas.consume ctxt Unparse_costs.public_key_readable >|? fun ctxt -> - (String (-1, Signature.Public_key.to_b58check k), ctxt) + (String (loc, Signature.Public_key.to_b58check k), ctxt) -let unparse_key_hash ctxt mode k = +let unparse_key_hash ~loc ctxt mode k = match mode with | Optimized | Optimized_legacy -> Gas.consume ctxt Unparse_costs.key_hash_optimized >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) | Readable -> Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt -> - (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) -let unparse_operation ctxt (op, _big_map_diff) = +let unparse_operation ~loc ctxt (op, _big_map_diff) = let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) -let unparse_chain_id ctxt mode chain_id = +let unparse_chain_id ~loc ctxt mode chain_id = match mode with | Optimized | Optimized_legacy -> Gas.consume ctxt Unparse_costs.chain_id_optimized >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) | Readable -> Gas.consume ctxt Unparse_costs.chain_id_readable >|? fun ctxt -> - (String (-1, Chain_id.to_b58check chain_id), ctxt) + (String (loc, Chain_id.to_b58check chain_id), ctxt) -let unparse_bls12_381_g1 ctxt x = +let unparse_bls12_381_g1 ~loc ctxt x = Gas.consume ctxt Unparse_costs.bls12_381_g1 >|? fun ctxt -> let bytes = Bls12_381.G1.to_bytes x in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) -let unparse_bls12_381_g2 ctxt x = +let unparse_bls12_381_g2 ~loc ctxt x = Gas.consume ctxt Unparse_costs.bls12_381_g2 >|? fun ctxt -> let bytes = Bls12_381.G2.to_bytes x in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) -let unparse_bls12_381_fr ctxt x = +let unparse_bls12_381_fr ~loc ctxt x = Gas.consume ctxt Unparse_costs.bls12_381_fr >|? fun ctxt -> let bytes = Bls12_381.Fr.to_bytes x in - (Bytes (-1, bytes), ctxt) + (Bytes (loc, bytes), ctxt) -let unparse_with_data_encoding ctxt s unparse_cost encoding = +let unparse_with_data_encoding ~loc ctxt s unparse_cost encoding = Lwt.return ( Gas.consume ctxt unparse_cost >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn encoding s in - (Bytes (-1, bytes), ctxt) ) + (Bytes (loc, bytes), ctxt) ) (* -- Unparsing data of complex types -- *) @@ -574,7 +576,7 @@ type ('ty, 'depth) comb_witness = | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness | Comb_Any : (_, _) comb_witness -let unparse_pair (type r) unparse_l unparse_r ctxt mode +let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) = unparse_l ctxt l >>=? fun (l, ctxt) -> unparse_r ctxt r >|=? fun (r, ctxt) -> @@ -593,35 +595,35 @@ let unparse_pair (type r) unparse_l unparse_r ctxt mode match (mode, r_comb_witness, r) with | (Optimized, Comb_Pair _, Micheline.Seq (_, r)) -> (* Optimized case n > 4 *) - Micheline.Seq (-1, l :: r) + Micheline.Seq (loc, l :: r) | ( Optimized, Comb_Pair (Comb_Pair _), Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> (* Optimized case n = 4 *) - Micheline.Seq (-1, [l; x2; x3; x4]) + Micheline.Seq (loc, [l; x2; x3; x4]) | (Readable, Comb_Pair _, Prim (_, D_Pair, xs, [])) -> (* Readable case n > 2 *) - Prim (-1, D_Pair, l :: xs, []) + Prim (loc, D_Pair, l :: xs, []) | _ -> (* The remaining cases are: - Optimized n = 2, - Optimized n = 3, and - Readable n = 2, - Optimized_legacy, any n *) - Prim (-1, D_Pair, [l; r], []) + Prim (loc, D_Pair, [l; r], []) in (res, ctxt) -let unparse_union unparse_l unparse_r ctxt = function +let unparse_union ~loc unparse_l unparse_r ctxt = function | L l -> - unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (-1, D_Left, [l], []), ctxt) + unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (loc, D_Left, [l], []), ctxt) | R r -> - unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (-1, D_Right, [r], []), ctxt) + unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (loc, D_Right, [r], []), ctxt) -let unparse_option unparse_v ctxt = function +let unparse_option ~loc unparse_v ctxt = function | Some v -> - unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (-1, D_Some, [v], []), ctxt) - | None -> return (Prim (-1, D_None, [], []), ctxt) + unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (loc, D_Some, [v], []), ctxt) + | None -> return (Prim (loc, D_None, [], []), ctxt) (* -- Unparsing data of comparable types -- *) @@ -632,13 +634,14 @@ let comparable_comb_witness2 : | _ -> Comb_Any let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : - type a. + type a loc. + loc:loc -> context -> unparsing_mode -> a comparable_ty -> a -> - (Script.node * context) tzresult Lwt.t = - fun ctxt mode ty a -> + ((loc, Script.prim) Micheline.node * context) tzresult Lwt.t = + fun ~loc ctxt mode ty a -> (* No need for stack_depth here. Unlike [unparse_data], [unparse_comparable_data] doesn't call [unparse_code]. The stack depth is bounded by the type depth, currently bounded @@ -649,32 +652,33 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : >>?= fun ctxt -> match (ty, a) with - | (Unit_key _, v) -> Lwt.return @@ unparse_unit ctxt v - | (Int_key _, v) -> Lwt.return @@ unparse_int ctxt v - | (Nat_key _, v) -> Lwt.return @@ unparse_nat ctxt v - | (String_key _, s) -> Lwt.return @@ unparse_string ctxt s - | (Bytes_key _, s) -> Lwt.return @@ unparse_bytes ctxt s - | (Bool_key _, b) -> Lwt.return @@ unparse_bool ctxt b - | (Timestamp_key _, t) -> Lwt.return @@ unparse_timestamp ctxt mode t - | (Address_key _, address) -> Lwt.return @@ unparse_address ctxt mode address - | (Signature_key _, s) -> Lwt.return @@ unparse_signature ctxt mode s - | (Mutez_key _, v) -> Lwt.return @@ unparse_mutez ctxt v - | (Key_key _, k) -> Lwt.return @@ unparse_key ctxt mode k - | (Key_hash_key _, k) -> Lwt.return @@ unparse_key_hash ctxt mode k + | (Unit_key _, v) -> Lwt.return @@ unparse_unit ~loc ctxt v + | (Int_key _, v) -> Lwt.return @@ unparse_int ~loc ctxt v + | (Nat_key _, v) -> Lwt.return @@ unparse_nat ~loc ctxt v + | (String_key _, s) -> Lwt.return @@ unparse_string ~loc ctxt s + | (Bytes_key _, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | (Bool_key _, b) -> Lwt.return @@ unparse_bool ~loc ctxt b + | (Timestamp_key _, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | (Address_key _, address) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | (Signature_key _, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | (Mutez_key _, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | (Key_key _, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | (Key_hash_key _, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k | (Chain_id_key _, chain_id) -> - Lwt.return @@ unparse_chain_id ctxt mode chain_id + Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id | (Pair_key ((tl, _), (tr, _), _), pair) -> let r_witness = comparable_comb_witness2 tr in - let unparse_l ctxt v = unparse_comparable_data ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ctxt mode tr v in - unparse_pair unparse_l unparse_r ctxt mode r_witness pair + let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in + unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair | (Union_key ((tl, _), (tr, _), _), v) -> - let unparse_l ctxt v = unparse_comparable_data ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ctxt mode tr v in - unparse_union unparse_l unparse_r ctxt v + let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in + unparse_union ~loc unparse_l unparse_r ctxt v | (Option_key (t, _), v) -> - let unparse_v ctxt v = unparse_comparable_data ctxt mode t v in - unparse_option unparse_v ctxt v + let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in + unparse_option ~loc unparse_v ctxt v | (Never_key _, _) -> . let pack_node unparsed ctxt = @@ -689,8 +693,8 @@ let pack_node unparsed ctxt = (bytes, ctxt) let pack_comparable_data ctxt typ data ~mode = - unparse_comparable_data ctxt mode typ data >>=? fun (unparsed, ctxt) -> - Lwt.return @@ pack_node unparsed ctxt + unparse_comparable_data ~loc:() ctxt mode typ data + >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt let hash_bytes ctxt bytes = Gas.consume ctxt (Michelson_v1_gas.Cost_of.Interpreter.blake2b bytes) @@ -5981,38 +5985,40 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a in match (ty, a) with - | (Unit_t _, v) -> Lwt.return @@ unparse_unit ctxt v - | (Int_t _, v) -> Lwt.return @@ unparse_int ctxt v - | (Nat_t _, v) -> Lwt.return @@ unparse_nat ctxt v - | (String_t _, s) -> Lwt.return @@ unparse_string ctxt s - | (Bytes_t _, s) -> Lwt.return @@ unparse_bytes ctxt s - | (Bool_t _, b) -> Lwt.return @@ unparse_bool ctxt b - | (Timestamp_t _, t) -> Lwt.return @@ unparse_timestamp ctxt mode t - | (Address_t _, address) -> Lwt.return @@ unparse_address ctxt mode address + | (Unit_t _, v) -> Lwt.return @@ unparse_unit ~loc:(-1) ctxt v + | (Int_t _, v) -> Lwt.return @@ unparse_int ~loc:(-1) ctxt v + | (Nat_t _, v) -> Lwt.return @@ unparse_nat ~loc:(-1) ctxt v + | (String_t _, s) -> Lwt.return @@ unparse_string ~loc:(-1) ctxt s + | (Bytes_t _, s) -> Lwt.return @@ unparse_bytes ~loc:(-1) ctxt s + | (Bool_t _, b) -> Lwt.return @@ unparse_bool ~loc:(-1) ctxt b + | (Timestamp_t _, t) -> Lwt.return @@ unparse_timestamp ~loc:(-1) ctxt mode t + | (Address_t _, address) -> + Lwt.return @@ unparse_address ~loc:(-1) ctxt mode address | (Contract_t _, contract) -> - Lwt.return @@ unparse_contract ctxt mode contract - | (Signature_t _, s) -> Lwt.return @@ unparse_signature ctxt mode s - | (Mutez_t _, v) -> Lwt.return @@ unparse_mutez ctxt v - | (Key_t _, k) -> Lwt.return @@ unparse_key ctxt mode k - | (Key_hash_t _, k) -> Lwt.return @@ unparse_key_hash ctxt mode k - | (Operation_t _, operation) -> Lwt.return @@ unparse_operation ctxt operation + Lwt.return @@ unparse_contract ~loc:(-1) ctxt mode contract + | (Signature_t _, s) -> Lwt.return @@ unparse_signature ~loc:(-1) ctxt mode s + | (Mutez_t _, v) -> Lwt.return @@ unparse_mutez ~loc:(-1) ctxt v + | (Key_t _, k) -> Lwt.return @@ unparse_key ~loc:(-1) ctxt mode k + | (Key_hash_t _, k) -> Lwt.return @@ unparse_key_hash ~loc:(-1) ctxt mode k + | (Operation_t _, operation) -> + Lwt.return @@ unparse_operation ~loc:(-1) ctxt operation | (Chain_id_t _, chain_id) -> - Lwt.return @@ unparse_chain_id ctxt mode chain_id - | (Bls12_381_g1_t _, x) -> Lwt.return @@ unparse_bls12_381_g1 ctxt x - | (Bls12_381_g2_t _, x) -> Lwt.return @@ unparse_bls12_381_g2 ctxt x - | (Bls12_381_fr_t _, x) -> Lwt.return @@ unparse_bls12_381_fr ctxt x + Lwt.return @@ unparse_chain_id ~loc:(-1) ctxt mode chain_id + | (Bls12_381_g1_t _, x) -> Lwt.return @@ unparse_bls12_381_g1 ~loc:(-1) ctxt x + | (Bls12_381_g2_t _, x) -> Lwt.return @@ unparse_bls12_381_g2 ~loc:(-1) ctxt x + | (Bls12_381_fr_t _, x) -> Lwt.return @@ unparse_bls12_381_fr ~loc:(-1) 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 let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_pair unparse_l unparse_r ctxt mode r_witness pair + unparse_pair ~loc:(-1) unparse_l unparse_r ctxt mode r_witness pair | (Union_t ((tl, _), (tr, _), _), v) -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_union unparse_l unparse_r ctxt v + unparse_union ~loc:(-1) unparse_l unparse_r ctxt v | (Option_t (t, _), v) -> let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in - unparse_option unparse_v ctxt v + unparse_option ~loc:(-1) unparse_v ctxt v | (List_t (t, _), items) -> List.fold_left_es (fun (l, ctxt) element -> @@ -6036,8 +6042,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : | (Set_t (t, _), set) -> List.fold_left_es (fun (l, ctxt) item -> - unparse_comparable_data ctxt mode t item >|=? fun (item, ctxt) -> - (item :: l, ctxt)) + unparse_comparable_data ~loc:(-1) ctxt mode t item + >|=? fun (item, ctxt) -> (item :: l, ctxt)) ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (-1, items), ctxt) @@ -6123,12 +6129,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ctxt ) ) | (Chest_key_t _, s) -> unparse_with_data_encoding + ~loc:(-1) ctxt s Unparse_costs.chest_key Timelock.chest_key_encoding | (Chest_t _, s) -> unparse_with_data_encoding + ~loc:(-1) ctxt s (Unparse_costs.chest ~plaintext_size:(Timelock.get_plaintext_size s)) @@ -6146,7 +6154,7 @@ and unparse_items : fun ctxt ~stack_depth mode kt vt items -> List.fold_left_es (fun (l, ctxt) (k, v) -> - unparse_comparable_data ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_comparable_data ~loc:(-1) ctxt mode kt k >>=? fun (key, ctxt) -> unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (-1, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) @@ -6369,7 +6377,7 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy List.fold_left_es (fun (acc, ctxt) (key_hash, key, value) -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - unparse_comparable_data ctxt mode key_type key + unparse_comparable_data ~loc:() ctxt mode key_type key >>=? fun (key_node, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt -> let key = Micheline.strip_locations key_node in -- GitLab From 497e38629d5940b8ac7aff3fa28b9e8538cc308e Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 13 Oct 2021 20:10:39 +0200 Subject: [PATCH 05/24] Proto: list_entrypoints do not need locations --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 11 +++++++---- src/proto_alpha/lib_protocol/script_ir_translator.mli | 3 ++- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 73451fc75691..a4cd9bd8da07 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5919,7 +5919,7 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = else if Entrypoints_map.mem name all then ok (List.rev path :: unreachables, all) else - unparse_ty ~loc:(-1) ctxt ty >>? fun (unparsed_ty, _) -> + unparse_ty ~loc:() ctxt ty >>? fun (unparsed_ty, _) -> ok ( unreachables, Entrypoints_map.add name (List.rev path, unparsed_ty) all ) @@ -5929,8 +5929,11 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = t ty -> prim list -> bool -> - prim list list * (prim list * Script.node) Entrypoints_map.t -> - (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult = + prim list list + * (prim list * (unit, Script.prim) Micheline.node) Entrypoints_map.t -> + (prim list list + * (prim list * (unit, Script.prim) Micheline.node) Entrypoints_map.t) + tzresult = fun t path reachable acc -> match t with | Union_t ((tl, al), (tr, ar), _) -> @@ -5949,7 +5952,7 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = acc | _ -> ok acc in - unparse_ty ~loc:(-1) ctxt full >>? fun (unparsed_full, _) -> + unparse_ty ~loc:() ctxt full >>? fun (unparsed_full, _) -> let (init, reachable) = match root_name with | None | Some (Field_annot "") -> (Entrypoints_map.empty, false) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 32defe08bec2..1a09d615831a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -411,7 +411,8 @@ val list_entrypoints : context -> root_name:Script_typed_ir.field_annot option -> (Michelson_v1_primitives.prim list list - * (Michelson_v1_primitives.prim list * Script.node) Entrypoints_map.t) + * (Michelson_v1_primitives.prim list * (unit, Script.prim) Micheline.node) + Entrypoints_map.t) tzresult val pack_data : -- GitLab From b197e29d464525dd3aa6b10d483f6d7bf54412ac Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 13 Oct 2021 20:15:52 +0200 Subject: [PATCH 06/24] Proto/Michelson: share dummy location --- .../lib_protocol/script_ir_translator.ml | 167 +++++++++--------- 1 file changed, 84 insertions(+), 83 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a4cd9bd8da07..73f4d6a820c2 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5987,41 +5987,42 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : fail Unparsing_too_many_recursive_calls else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a in + let loc = -1 in match (ty, a) with - | (Unit_t _, v) -> Lwt.return @@ unparse_unit ~loc:(-1) ctxt v - | (Int_t _, v) -> Lwt.return @@ unparse_int ~loc:(-1) ctxt v - | (Nat_t _, v) -> Lwt.return @@ unparse_nat ~loc:(-1) ctxt v - | (String_t _, s) -> Lwt.return @@ unparse_string ~loc:(-1) ctxt s - | (Bytes_t _, s) -> Lwt.return @@ unparse_bytes ~loc:(-1) ctxt s - | (Bool_t _, b) -> Lwt.return @@ unparse_bool ~loc:(-1) ctxt b - | (Timestamp_t _, t) -> Lwt.return @@ unparse_timestamp ~loc:(-1) ctxt 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 @@ unparse_address ~loc:(-1) ctxt mode address + Lwt.return @@ unparse_address ~loc ctxt mode address | (Contract_t _, contract) -> - Lwt.return @@ unparse_contract ~loc:(-1) ctxt mode contract - | (Signature_t _, s) -> Lwt.return @@ unparse_signature ~loc:(-1) ctxt mode s - | (Mutez_t _, v) -> Lwt.return @@ unparse_mutez ~loc:(-1) ctxt v - | (Key_t _, k) -> Lwt.return @@ unparse_key ~loc:(-1) ctxt mode k - | (Key_hash_t _, k) -> Lwt.return @@ unparse_key_hash ~loc:(-1) ctxt 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 @@ unparse_operation ~loc:(-1) ctxt operation + Lwt.return @@ unparse_operation ~loc ctxt operation | (Chain_id_t _, chain_id) -> - Lwt.return @@ unparse_chain_id ~loc:(-1) ctxt mode chain_id - | (Bls12_381_g1_t _, x) -> Lwt.return @@ unparse_bls12_381_g1 ~loc:(-1) ctxt x - | (Bls12_381_g2_t _, x) -> Lwt.return @@ unparse_bls12_381_g2 ~loc:(-1) ctxt x - | (Bls12_381_fr_t _, x) -> Lwt.return @@ unparse_bls12_381_fr ~loc:(-1) ctxt 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 let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_pair ~loc:(-1) unparse_l unparse_r ctxt mode r_witness pair + unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair | (Union_t ((tl, _), (tr, _), _), v) -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_union ~loc:(-1) unparse_l unparse_r ctxt v + unparse_union ~loc unparse_l unparse_r ctxt v | (Option_t (t, _), v) -> let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in - unparse_option ~loc:(-1) unparse_v ctxt v + unparse_option ~loc unparse_v ctxt v | (List_t (t, _), items) -> List.fold_left_es (fun (l, ctxt) element -> @@ -6029,12 +6030,10 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt)) ([], ctxt) items.elements - >|=? fun (items, ctxt) -> (Micheline.Seq (-1, List.rev items), ctxt) + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) | (Ticket_t (t, _), {ticketer; contents; amount}) -> - (let fake_loc = -1 in - (* ideally we would like to allow a little overhead here because it is only used for unparsing *) - opened_ticket_type fake_loc t) - >>?= fun opened_ticket_ty -> + (* ideally we would like to allow a little overhead here because it is only used for unparsing *) + opened_ticket_type loc t >>?= fun opened_ticket_ty -> let t = ty_of_comparable_ty opened_ticket_ty in (unparse_data [@tailcall]) ctxt @@ -6045,18 +6044,18 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : | (Set_t (t, _), set) -> List.fold_left_es (fun (l, ctxt) item -> - unparse_comparable_data ~loc:(-1) ctxt mode t item - >|=? fun (item, ctxt) -> (item :: l, ctxt)) + unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> + (item :: l, ctxt)) ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) - >|=? fun (items, ctxt) -> (Micheline.Seq (-1, items), ctxt) + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | (Map_t (kt, vt, _), map) -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (-1, items), ctxt) + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | (Big_map_t (_kt, _vt, _), {id = Some id; diff = {size; _}; _}) when Compare.Int.( = ) size 0 -> - return (Micheline.Int (-1, Big_map.Id.unparse_to_z id), ctxt) + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) | (Big_map_t (kt, vt, _), {id = Some id; diff = {map; _}; _}) -> let items = Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] @@ -6073,13 +6072,13 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : in (* this can't fail if the original type is well-formed because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t (-1) vt ~annot:None >>?= fun vt -> + option_t loc vt ~annot:None >>?= fun vt -> unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> ( Micheline.Prim - ( -1, + ( loc, D_Pair, - [Int (-1, Big_map.Id.unparse_to_z id); Seq (-1, items)], + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], [] ), ctxt ) | (Big_map_t (kt, vt, _), {id = None; diff = {map; _}; _}) -> @@ -6097,7 +6096,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : items in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (-1, items), ctxt) + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | (Lambda_t _, Lam (_, original_code)) -> unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code | (Never_t _, _) -> . @@ -6107,39 +6106,39 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let bytes = Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in - (Bytes (-1, bytes), ctxt) ) + (Bytes (loc, bytes), ctxt) ) | (Sapling_state_t _, {id; diff; _}) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with | {commitments_and_ciphertexts = []; nullifiers = []} -> ( match id with - | None -> Micheline.Seq (-1, []) + | None -> Micheline.Seq (loc, []) | Some id -> let id = Sapling.Id.unparse_to_z id in - Micheline.Int (-1, id)) + Micheline.Int (loc, id)) | diff -> ( let diff_bytes = Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff in - let unparsed_diff = Bytes (-1, diff_bytes) in + let unparsed_diff = Bytes (loc, diff_bytes) in match id with | None -> unparsed_diff | Some id -> let id = Sapling.Id.unparse_to_z id in Micheline.Prim - (-1, D_Pair, [Int (-1, id); unparsed_diff], []))), + (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) | (Chest_key_t _, s) -> unparse_with_data_encoding - ~loc:(-1) + ~loc ctxt s Unparse_costs.chest_key Timelock.chest_key_encoding | (Chest_t _, s) -> unparse_with_data_encoding - ~loc:(-1) + ~loc ctxt s (Unparse_costs.chest ~plaintext_size:(Timelock.get_plaintext_size s)) @@ -6157,9 +6156,10 @@ and unparse_items : fun ctxt ~stack_depth mode kt vt items -> List.fold_left_es (fun (l, ctxt) (k, v) -> - unparse_comparable_data ~loc:(-1) ctxt mode kt k >>=? fun (key, ctxt) -> + let loc = -1 in + unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v - >|=? fun (value, ctxt) -> (Prim (-1, D_Elt, [key; value], []) :: l, ctxt)) + >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) items @@ -6223,45 +6223,46 @@ let unparse_script ctxt mode unparse_data ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> Lwt.return - ( unparse_ty ~loc:(-1) ctxt arg_type >>? fun (arg_type, ctxt) -> - unparse_ty ~loc:(-1) ctxt storage_type >>? fun (storage_type, ctxt) -> - let arg_type = add_field_annot root_name None arg_type in - let open Micheline in - let view name {input_ty; output_ty; view_code} views = - Prim - ( -1, - K_view, - [ - String (-1, Script_string.to_string name); - input_ty; - output_ty; - view_code; - ], - [] ) - :: views - in - let views = SMap.fold view views [] |> List.rev in - let code = - Seq - ( -1, - [ - Prim (-1, K_parameter, [arg_type], []); - Prim (-1, K_storage, [storage_type], []); - Prim (-1, K_code, [code], []); - ] - @ views ) - in - Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> - Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> - Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> - Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> - Gas.consume ctxt (Script.strip_locations_cost code) >>? fun ctxt -> - Gas.consume ctxt (Script.strip_locations_cost storage) >|? fun ctxt -> - ( { - code = lazy_expr (strip_locations code); - storage = lazy_expr (strip_locations storage); - }, - ctxt ) ) + (let loc = -1 in + unparse_ty ~loc ctxt arg_type >>? fun (arg_type, ctxt) -> + unparse_ty ~loc ctxt storage_type >>? fun (storage_type, ctxt) -> + let arg_type = add_field_annot root_name None arg_type in + let open Micheline in + let view name {input_ty; output_ty; view_code} views = + Prim + ( loc, + K_view, + [ + String (loc, Script_string.to_string name); + input_ty; + output_ty; + view_code; + ], + [] ) + :: views + in + let views = SMap.fold view views [] |> List.rev in + let code = + Seq + ( loc, + [ + Prim (loc, K_parameter, [arg_type], []); + Prim (loc, K_storage, [storage_type], []); + Prim (loc, K_code, [code], []); + ] + @ views ) + in + Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> + Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> + Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> + Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>? fun ctxt -> + Gas.consume ctxt (Script.strip_locations_cost code) >>? fun ctxt -> + Gas.consume ctxt (Script.strip_locations_cost storage) >|? fun ctxt -> + ( { + code = lazy_expr (strip_locations code); + storage = lazy_expr (strip_locations storage); + }, + ctxt )) let pack_data_with_mode ctxt typ data ~mode = unparse_data ~stack_depth:0 ctxt mode typ data >>=? fun (unparsed, ctxt) -> -- GitLab From 864258be2d5748f49c92f7542d0a19bea872e9b6 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 14 Oct 2021 11:46:26 +0200 Subject: [PATCH 07/24] Proto/Michelson: share dummy locations (part 2) --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 73f4d6a820c2..6f74da5cf426 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1987,21 +1987,23 @@ let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = | None -> false | Some (Field_annot l) -> Compare.String.(l = entrypoint) in + let loc = -1 in let rec find_entrypoint : type t. t ty -> string -> ((Script.node -> Script.node) * ex_ty) option = fun t entrypoint -> match t with | Union_t ((tl, al), (tr, ar), _) -> ( if annot_is_entrypoint entrypoint al then - Some ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl) + Some ((fun e -> Prim (loc, D_Left, [e], [])), Ex_ty tl) else if annot_is_entrypoint entrypoint ar then - Some ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr) + Some ((fun e -> Prim (loc, D_Right, [e], [])), Ex_ty tr) else match find_entrypoint tl entrypoint with - | Some (f, t) -> Some ((fun e -> Prim (0, D_Left, [f e], [])), t) + | Some (f, t) -> Some ((fun e -> Prim (loc, D_Left, [f e], [])), t) | None -> ( match find_entrypoint tr entrypoint with - | Some (f, t) -> Some ((fun e -> Prim (0, D_Right, [f e], [])), t) + | Some (f, t) -> + Some ((fun e -> Prim (loc, D_Right, [f e], [])), t) | None -> None)) | _ -> None in -- GitLab From 65de32d223d63f151f2b9c5089b6a29733e3c7a5 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 14 Oct 2021 11:40:56 +0200 Subject: [PATCH 08/24] Proto/Michelson: share dummy locations (part 3) --- .../lib_protocol/script_interpreter_defs.ml | 27 ++++++++++--------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index ecc67201fbae..cc100d5f54dd 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -568,7 +568,8 @@ let apply ctxt gas capture_ty capture lam = let (Item_t (full_arg_ty, _, _)) = descr.kbef in let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> - unparse_ty ~loc:(-1) ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + let loc = -1 in + unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> match full_arg_ty with | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _) -> let arg_stack_ty = Item_t (arg_ty, Bot_t, None) in @@ -590,10 +591,10 @@ let apply ctxt gas capture_ty capture lam = in let full_expr = Micheline.Seq - ( 0, + ( loc, [ - Prim (0, I_PUSH, [ty_expr; const_expr], []); - Prim (0, I_PAIR, [], []); + Prim (loc, I_PUSH, [ty_expr; const_expr], []); + Prim (loc, I_PAIR, [], []); expr; ] ) in @@ -649,19 +650,19 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = let create_contract (ctxt, sc) gas storage_type param_type code views root_name delegate credit init = let ctxt = update_context gas ctxt in - unparse_ty ~loc:(-1) ctxt param_type >>?= fun (unparsed_param_type, ctxt) -> + let loc = -1 in + unparse_ty ~loc ctxt param_type >>?= fun (unparsed_param_type, ctxt) -> let unparsed_param_type = Script_ir_translator.add_field_annot root_name None unparsed_param_type in - unparse_ty ~loc:(-1) ctxt storage_type - >>?= fun (unparsed_storage_type, ctxt) -> + unparse_ty ~loc ctxt storage_type >>?= fun (unparsed_storage_type, ctxt) -> let open Micheline in let view name {input_ty; output_ty; view_code} views = Prim - ( 0, + ( loc, K_view, [ - String (0, Script_string.to_string name); + String (loc, Script_string.to_string name); input_ty; output_ty; view_code; @@ -673,11 +674,11 @@ let create_contract (ctxt, sc) gas storage_type param_type code views root_name let code = strip_locations (Seq - ( 0, + ( loc, [ - Prim (0, K_parameter, [unparsed_param_type], []); - Prim (0, K_storage, [unparsed_storage_type], []); - Prim (0, K_code, [code], []); + Prim (loc, K_parameter, [unparsed_param_type], []); + Prim (loc, K_storage, [unparsed_storage_type], []); + Prim (loc, K_code, [code], []); ] @ views )) in -- GitLab From 61a1d2e42512fcb84e1cfcabeef1ed2ca3d4b4ea Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 14 Oct 2021 12:41:40 +0200 Subject: [PATCH 09/24] Proto/GTOC: generalize location for bottom_up_fold_cps --- src/proto_alpha/lib_protocol/alpha_context.mli | 8 ++++---- .../lib_protocol/global_constants_storage.mli | 12 ++++++++---- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 804ff73a453b..2b23ba030c92 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -745,11 +745,11 @@ module Global_constants_storage : sig continuation in `f`. *) val bottom_up_fold_cps : 'accumulator -> - Script.node -> - ('accumulator -> Script.node -> 'return) -> + ('loc, Script.prim) Micheline.node -> + ('accumulator -> ('loc, Script.prim) Micheline.node -> 'return) -> ('accumulator -> - Script_repr.node -> - ('accumulator -> Script.node -> 'return) -> + ('loc, Script.prim) Micheline.node -> + ('accumulator -> ('loc, Script.prim) Micheline.node -> 'return) -> 'return) -> 'return diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.mli b/src/proto_alpha/lib_protocol/global_constants_storage.mli index 6c4116c15568..5872ec9afa6c 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.mli +++ b/src/proto_alpha/lib_protocol/global_constants_storage.mli @@ -130,11 +130,15 @@ module Internal_for_tests : sig *) val bottom_up_fold_cps : 'accumulator -> - Script_repr.node -> - ('accumulator -> Script_repr.node -> 'return) -> + ('loc, Michelson_v1_primitives.prim) Micheline.node -> ('accumulator -> - Script_repr.node -> - ('accumulator -> Script_repr.node -> 'return) -> + ('loc, Michelson_v1_primitives.prim) Micheline.node -> + 'return) -> + ('accumulator -> + ('loc, Michelson_v1_primitives.prim) Micheline.node -> + ('accumulator -> + ('loc, Michelson_v1_primitives.prim) Micheline.node -> + 'return) -> 'return) -> 'return -- GitLab From e3cab862be3023341fd92bad2475e79402536cf1 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:35:38 +0200 Subject: [PATCH 10/24] Proto/Michelson: reuse location to make typechecker happy Since locations are stripped, we could have used unit instead but it would have meant change Int/String/Bytes cases to not reuse the nodes as is, which would create a bit more garbage. --- .../lib_protocol/michelson_v1_primitives.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 5197d0a887af..8e83bf62c8c7 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -546,8 +546,8 @@ let prims_of_strings expr = (Invalid_primitive_name (expr, loc)) (prim_of_string prim) >>? fun prim -> - List.map_e convert args >|? fun args -> Prim (0, prim, args, annot) - | Seq (_, args) -> List.map_e convert args >|? fun args -> Seq (0, args) + List.map_e convert args >|? fun args -> Prim (loc, prim, args, annot) + | Seq (loc, args) -> List.map_e convert args >|? fun args -> Seq (loc, args) in convert (root expr) >|? fun expr -> strip_locations expr [@@coq_axiom_with_reason @@ -556,13 +556,13 @@ let prims_of_strings expr = let strings_of_prims expr = let rec convert = function | (Int _ | String _ | Bytes _) as expr -> expr - | Prim (_, prim, args, annot) -> + | Prim (loc, prim, args, annot) -> let prim = string_of_prim prim in let args = List.map convert args in - Prim (0, prim, args, annot) - | Seq (_, args) -> + Prim (loc, prim, args, annot) + | Seq (loc, args) -> let args = List.map convert args in - Seq (0, args) + Seq (loc, args) in strip_locations (convert (root expr)) [@@coq_axiom_with_reason -- GitLab From d99a4b58152567dc576fdf999b6f1ee9067eede7 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 14 Oct 2021 12:31:28 +0200 Subject: [PATCH 11/24] Tests/proto: do not use location if they are stripped --- .../lib_protocol/test/helpers/op.ml | 21 +++++----- .../lib_protocol/test/test_typechecking.ml | 40 +++++++++---------- .../unit/test_global_constants_storage.ml | 6 +-- 3 files changed, 35 insertions(+), 32 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index cb3eb6e091c6..e3cefa2fd0de 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -392,26 +392,29 @@ let dummy_script = lazy_expr (strip_locations (Seq - ( 0, + ( (), [ - Prim (0, K_parameter, [Prim (0, T_unit, [], [])], []); - Prim (0, K_storage, [Prim (0, T_unit, [], [])], []); + Prim ((), K_parameter, [Prim ((), T_unit, [], [])], []); + Prim ((), K_storage, [Prim ((), T_unit, [], [])], []); Prim - ( 0, + ( (), K_code, [ Seq - ( 0, + ( (), [ - Prim (0, I_CDR, [], []); + Prim ((), I_CDR, [], []); Prim - (0, I_NIL, [Prim (0, T_operation, [], [])], []); - Prim (0, I_PAIR, [], []); + ( (), + I_NIL, + [Prim ((), T_operation, [], [])], + [] ); + Prim ((), I_PAIR, [], []); ] ); ], [] ); ] ))); - storage = lazy_expr (strip_locations (Prim (0, D_Unit, [], []))); + storage = lazy_expr (strip_locations (Prim ((), D_Unit, [], []))); } let dummy_script_cost = Test_tez.Tez.of_mutez_exn 9_500L diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index 5c2a8068de17..45d4a099cf54 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -307,19 +307,19 @@ let test_parse_comb_type () = let test_unparse_ty loc ctxt expected ty = Environment.wrap_tzresult - ( Script_ir_translator.unparse_ty ~loc:(-1) ctxt ty >>? fun (actual, ctxt) -> + ( Script_ir_translator.unparse_ty ~loc:() ctxt ty >>? fun (actual, ctxt) -> if actual = expected then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) let test_unparse_comb_type () = let open Script in let open Script_typed_ir in - let nat_prim = Prim (-1, T_nat, [], []) in - let nat_prim_a = Prim (-1, T_nat, [], ["%a"]) in - let nat_prim_b = Prim (-1, T_nat, [], ["%b"]) in - let nat_prim_c = Prim (-1, T_nat, [], ["%c"]) in + let nat_prim = Prim ((), T_nat, [], []) in + let nat_prim_a = Prim ((), T_nat, [], ["%a"]) in + let nat_prim_b = Prim ((), T_nat, [], ["%b"]) in + let nat_prim_c = Prim ((), T_nat, [], ["%c"]) in let nat_ty = nat_t ~annot:None in - let pair_prim l = Prim (-1, T_pair, l, []) in + let pair_prim l = Prim ((), T_pair, l, []) in let pair_ty ty1 ty2 = pair_t (-1) (ty1, None, None) (ty2, None, None) ~annot:None in @@ -416,7 +416,7 @@ let test_unparse_comb_type () = test_unparse_ty __LOC__ ctxt - (pair_prim2 nat_prim_a (Prim (-1, T_pair, [nat_prim; nat_prim], ["%b"]))) + (pair_prim2 nat_prim_a (Prim ((), T_pair, [nat_prim; nat_prim], ["%b"]))) pair_nat_a_pair_b_nat_nat_ty >>?= fun ctxt -> (* pair nat (pair @b nat nat) *) @@ -429,7 +429,7 @@ let test_unparse_comb_type () = test_unparse_ty __LOC__ ctxt - (pair_prim2 nat_prim (Prim (-1, T_pair, [nat_prim; nat_prim], ["@b"]))) + (pair_prim2 nat_prim (Prim ((), T_pair, [nat_prim; nat_prim], ["@b"]))) pair_nat_pair_b_nat_nat_ty >>?= fun ctxt -> (* pair nat (pair :b nat nat) *) @@ -444,7 +444,7 @@ let test_unparse_comb_type () = test_unparse_ty __LOC__ ctxt - (pair_prim2 nat_prim (Prim (-1, T_pair, [nat_prim; nat_prim], [":b"]))) + (pair_prim2 nat_prim (Prim ((), T_pair, [nat_prim; nat_prim], [":b"]))) pair_nat_pair_b_nat_nat_ty >>?= fun _ -> return_unit @@ -454,20 +454,20 @@ let test_unparse_comparable_ty loc ctxt expected ty = let open Script_typed_ir in Environment.wrap_tzresult ( set_t (-1) ty ~annot:None >>? fun set_ty_ty -> - Script_ir_translator.unparse_ty ~loc:(-1) ctxt set_ty_ty + Script_ir_translator.unparse_ty ~loc:() ctxt set_ty_ty >>? fun (actual, ctxt) -> - if actual = Prim (-1, T_set, [expected], []) then ok ctxt + if actual = Prim ((), T_set, [expected], []) then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) let test_unparse_comb_comparable_type () = let open Script in let open Script_typed_ir in - let nat_prim = Prim (-1, T_nat, [], []) in - let nat_prim_a = Prim (-1, T_nat, [], ["%a"]) in - let nat_prim_b = Prim (-1, T_nat, [], ["%b"]) in - let nat_prim_c = Prim (-1, T_nat, [], ["%c"]) in + let nat_prim = Prim ((), T_nat, [], []) in + let nat_prim_a = Prim ((), T_nat, [], ["%a"]) in + let nat_prim_b = Prim ((), T_nat, [], ["%b"]) in + let nat_prim_c = Prim ((), T_nat, [], ["%c"]) in let nat_ty = nat_key ~annot:None in - let pair_prim l = Prim (-1, T_pair, l, []) in + let pair_prim l = Prim ((), T_pair, l, []) in let pair_ty ty1 ty2 = pair_key (-1) (ty1, None) (ty2, None) ~annot:None in let pair_prim2 a b = pair_prim [a; b] in let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in @@ -552,7 +552,7 @@ let test_unparse_comb_comparable_type () = test_unparse_comparable_ty __LOC__ ctxt - (pair_prim2 nat_prim_a (Prim (-1, T_pair, [nat_prim; nat_prim], ["%b"]))) + (pair_prim2 nat_prim_a (Prim ((), T_pair, [nat_prim; nat_prim], ["%b"]))) pair_nat_a_pair_b_nat_nat_ty >>?= fun ctxt -> (* pair nat (pair :b nat nat) *) @@ -563,7 +563,7 @@ let test_unparse_comb_comparable_type () = test_unparse_comparable_ty __LOC__ ctxt - (pair_prim2 nat_prim (Prim (-1, T_pair, [nat_prim; nat_prim], [":b"]))) + (pair_prim2 nat_prim (Prim ((), T_pair, [nat_prim; nat_prim], [":b"]))) pair_nat_pair_b_nat_nat_ty >>?= fun _ -> return_unit @@ -811,7 +811,7 @@ let test_unparse_comb_data () = (* Generate all the possible syntaxes for pairs *) let gen_pairs left right = - [Prim (-1, Script.D_Pair, [left; right], []); Seq (-1, [left; right])] + [Prim ((), Script.D_Pair, [left; right], []); Seq ((), [left; right])] (* Generate all the possible syntaxes for combs *) let rec gen_combs leaf arity = @@ -832,7 +832,7 @@ let rec gen_combs leaf arity = let test_optimal_comb () = let open Script_typed_ir in let leaf_ty = nat_t ~annot:None in - let leaf_mich = Int (-1, Z.zero) in + let leaf_mich = Int ((), Z.zero) in let leaf_v = Script_int.zero_n in let size_of_micheline mich = let canonical = Micheline.strip_locations mich in diff --git a/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml index 774e3c7cd12d..ef46e9552292 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml @@ -101,7 +101,7 @@ let test_register_fails_with_unregistered_references_pbt = >>= assert_proto_error_id __LOC__ "Nonexistent_global") let rec grow n node = - match n with n when n <= 0 -> node | n -> grow (n - 1) (Seq (-1, [node])) + match n with n when n <= 0 -> node | n -> grow (n - 1) (Seq ((), [node])) (* Any expression with a depth that exceeds [Global_constants_storage.max_allowed_global_constant_depth] @@ -111,7 +111,7 @@ let test_register_fails_if_too_deep = let vdeep_expr = grow (Constants_repr.max_allowed_global_constant_depth + 1) - (Int (-1, Z.of_int 1)) + (Int ((), Z.of_int 1)) |> Micheline.strip_locations in create_context () >>=? fun context -> @@ -383,7 +383,7 @@ let test_expand_is_idempotent = given large values. *) let test_fold_does_not_stack_overflow = tztest "bottom_up_fold_cps: does not stack overflow" `Quick (fun () -> - let node = grow 1_000_000 @@ Int (-1, Z.zero) in + let node = grow 1_000_000 @@ Int ((), Z.zero) in return @@ ignore @@ Global_constants_storage.Internal_for_tests.bottom_up_fold_cps () -- GitLab From 81fe87cdead46ca3316a1c1374c65dd357f6fa66 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 14 Oct 2021 14:54:26 +0200 Subject: [PATCH 12/24] Proto/Client: make loc mandatory, generalize loc, use unit when possible --- .../lib_client/client_proto_fa12.ml | 63 ++++++++++--------- .../lib_client/client_proto_fa12.mli | 8 ++- .../lib_client/client_proto_multisig.ml | 12 ++-- 3 files changed, 45 insertions(+), 38 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index 4d0e658460be..a69c3e7d0e5b 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -243,7 +243,7 @@ let pair ~loc a b = Micheline.Prim (loc, Script.D_Pair, [a; b], []) let nat ~loc i = Micheline.Int (loc, i) -let unit ~loc () = Micheline.Prim (loc, Script.D_Unit, [], []) +let unit ~loc = Micheline.Prim (loc, Script.D_Unit, [], []) let bytes ~loc b = Micheline.Bytes (loc, b) @@ -265,7 +265,7 @@ type type_eq_combinator = Script.node * (Script.node -> bool) (** [t_pair ~loc l] takes a list of types and respective equivalence check functions, and returns a type of n-ary pair of such types and a function checking syntactical equivalence with another node. *) -let t_pair ?(loc = 0) l : type_eq_combinator = +let t_pair ~loc l : type_eq_combinator = let (values, are_ty) = List.split l in let is_pair p = match p with @@ -282,26 +282,26 @@ let t_pair ?(loc = 0) l : type_eq_combinator = in (Micheline.Prim (loc, Script.T_pair, values, []), is_pair) -(** [t_unit ~loc ()] returns a Micheline node for the `unit` type, and +(** [t_unit ~loc] returns a Micheline node for the `unit` type, and a function checking another node is syntactically equivalent. *) -let t_unit ?(loc = 0) () : type_eq_combinator = +let t_unit ~loc : type_eq_combinator = let is_unit p = match p with Micheline.Prim (_, Script.T_unit, [], _) -> true | _ -> false in (Micheline.Prim (loc, Script.T_unit, [], []), is_unit) -(** [t_nat ~loc ()] returns a Micheline node for the `nat` type, and +(** [t_nat ~loc] returns a Micheline node for the `nat` type, and a function checking another node is syntactically equivalent. *) -let t_nat ?(loc = 0) () : type_eq_combinator = +let t_nat ~loc : type_eq_combinator = let is_nat p = match p with Micheline.Prim (_, Script.T_nat, [], _) -> true | _ -> false in (Micheline.Prim (loc, Script.T_nat, [], []), is_nat) -(** [t_address ~loc ()] returns a Micheline node for the `address` +(** [t_address ~loc] returns a Micheline node for the `address` type, and a function checking another node is syntactically equivalent. *) -let t_address ?(loc = 0) () : type_eq_combinator = +let t_address ~loc : type_eq_combinator = let is_address p = match p with | Micheline.Prim (_, Script.T_address, [], _) -> true @@ -313,7 +313,7 @@ let t_address ?(loc = 0) () : type_eq_combinator = type and its own syntactical equivalence checker, and returns a Micheline node for the type `contract c`, and a function checking another node is syntactically equivalent. *) -let t_contract ?(loc = 0) (a, is_a) : type_eq_combinator = +let t_contract ~loc (a, is_a) : type_eq_combinator = let is_contract c = match c with | Micheline.Prim (_, Script.T_contract, [a], _) -> is_a a @@ -327,7 +327,7 @@ let t_contract ?(loc = 0) (a, is_a) : type_eq_combinator = syntactically equivalent. The view type is defined by [TZIP4](https://gitlab.com/tzip/tzip/-/blob/master/proposals/tzip-4/tzip-4.md). *) -let t_view ?loc a b : type_eq_combinator = t_pair ?loc [a; t_contract ?loc b] +let t_view ~loc a b : type_eq_combinator = t_pair ~loc [a; t_contract ~loc b] (** * Actions *) @@ -459,34 +459,37 @@ let action_encoding = getTotalSupply_encoding; ] -let transfer_type = t_pair [t_address (); t_address (); t_nat ()] +let transfer_type ~loc = + t_pair ~loc [t_address ~loc; t_address ~loc; t_nat ~loc] -let approve_type = t_pair [t_address (); t_nat ()] +let approve_type ~loc = t_pair ~loc [t_address ~loc; t_nat ~loc] -let getAllowance_type = t_view (t_pair [t_address (); t_address ()]) (t_nat ()) +let getAllowance_type ~loc = + t_view ~loc (t_pair ~loc [t_address ~loc; t_address ~loc]) (t_nat ~loc) -let getBalance_type = t_view (t_address ()) (t_nat ()) +let getBalance_type ~loc = t_view ~loc (t_address ~loc) (t_nat ~loc) -let getTotalSupply_type = t_view (t_unit ()) (t_nat ()) +let getTotalSupply_type ~loc = t_view ~loc (t_unit ~loc) (t_nat ~loc) let standard_entrypoints = + let loc = -1 in [ - ("transfer", transfer_type); - ("approve", approve_type); - ("getAllowance", getAllowance_type); - ("getBalance", getBalance_type); - ("getTotalSupply", getTotalSupply_type); + ("transfer", transfer_type ~loc); + ("approve", approve_type ~loc); + ("getAllowance", getAllowance_type ~loc); + ("getBalance", getBalance_type ~loc); + ("getTotalSupply", getTotalSupply_type ~loc); ] -let view_input ?(loc = 0) action = +let view_input ~loc action = match action with | Get_allowance (source, destination, _) -> pair ~loc (address ~loc source) (address ~loc destination) | Get_balance (addr, _) -> address ~loc addr - | Get_total_supply _ -> unit ~loc () - | _ -> unit ~loc () + | Get_total_supply _ -> unit ~loc + | _ -> unit ~loc -let action_to_expr ?(loc = 0) action = +let action_to_expr ~loc action = match action with | Transfer (source, destination, amount) -> pair @@ -495,13 +498,13 @@ let action_to_expr ?(loc = 0) action = (pair ~loc (address ~loc destination) (nat ~loc amount)) | Approve (addr, amount) -> pair ~loc (address ~loc addr) (nat ~loc amount) | Get_allowance (_, _, (cb, entrypoint)) -> - let input = view_input action in + let input = view_input ~loc action in pair ~loc input (callback ~loc ?entrypoint cb) | Get_balance (_, (cb, entrypoint)) -> - let input = view_input action in + let input = view_input ~loc action in pair ~loc input (callback ~loc ?entrypoint cb) | Get_total_supply (cb, entrypoint) -> - let input = view_input action in + let input = view_input ~loc action in pair ~loc input (callback ~loc ?entrypoint cb) let parse_address error = function @@ -717,7 +720,7 @@ let contract_has_fa12_interface : let translate_action_to_argument action = let entrypoint = action_to_entrypoint action in - let expr = Micheline.strip_locations (action_to_expr action) in + let expr = Micheline.strip_locations (action_to_expr ~loc:() action) in (entrypoint, Format.asprintf "%a" Michelson_v1_printer.print_expr expr) let parse_error = @@ -854,7 +857,7 @@ let build_transaction_operation ?(tez_amount = Tez.zero) ?fee ?gas_limit ?storage_limit token action = let entrypoint = action_to_entrypoint action in let parameters = - Script.lazy_expr (Micheline.strip_locations (action_to_expr action)) + Script.lazy_expr (Micheline.strip_locations (action_to_expr ~loc:() action)) in let operation = Transaction @@ -950,7 +953,7 @@ let run_view_action (cctxt : #Protocol_client_context.full) ~chain ~block is_viewable_action action >>=? fun () -> contract_has_fa12_interface cctxt ~chain ~block ~contract () >>=? fun () -> let entrypoint = action_to_entrypoint action in - let input = Micheline.strip_locations (view_input action) in + let input = Micheline.strip_locations (view_input ~loc:() action) in Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> Plugin.RPC.Scripts.run_view cctxt diff --git a/src/proto_alpha/lib_client/client_proto_fa12.mli b/src/proto_alpha/lib_client/client_proto_fa12.mli index c712af89a2dd..8022bd2d7986 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.mli +++ b/src/proto_alpha/lib_client/client_proto_fa12.mli @@ -54,9 +54,13 @@ val print_action : Format.formatter -> action -> unit val action_encoding : action Data_encoding.encoding -val action_to_expr : ?loc:Script.location -> action -> Script.node +val action_to_expr : + loc:'loc -> action -> ('loc, Script.prim) Tezos_micheline.Micheline.node -val action_of_expr : entrypoint:string -> Script.node -> action tzresult +val action_of_expr : + entrypoint:string -> + (_, Script.prim) Tezos_micheline.Micheline.node -> + action tzresult (** [convert_wrapped_parameter_into_action ccctx ~chain ~block ~contract parameter] converts a wrapped FA1.2 contract [parameter] diff --git a/src/proto_alpha/lib_client/client_proto_multisig.ml b/src/proto_alpha/lib_client/client_proto_multisig.ml index 8a9dd286262b..0a7429d36642 100644 --- a/src/proto_alpha/lib_client/client_proto_multisig.ml +++ b/src/proto_alpha/lib_client/client_proto_multisig.ml @@ -640,11 +640,11 @@ let action_to_expr_generic ~loc = function let action_to_expr_legacy ~loc = function | Transfer {amount; destination; entrypoint; parameter_type; parameter} -> - if parameter <> Tezos_micheline.Micheline.strip_locations (unit ~loc:0) + if parameter <> Tezos_micheline.Micheline.strip_locations (unit ~loc:()) then Error_monad.error @@ Unsupported_feature_generic_call parameter else if parameter_type - <> Tezos_micheline.Micheline.strip_locations (unit_t ~loc:0) + <> Tezos_micheline.Micheline.strip_locations (unit_t ~loc:()) then Error_monad.error @@ Unsupported_feature_generic_call_ty parameter_type else @@ -739,9 +739,9 @@ let action_of_expr_not_generic e = Data_encoding.Binary.of_bytes_exn Contract.encoding s; entrypoint = "default"; parameter_type = - Tezos_micheline.Micheline.strip_locations @@ unit_t ~loc:0; + Tezos_micheline.Micheline.strip_locations @@ unit_t ~loc:(); parameter = - Tezos_micheline.Micheline.strip_locations @@ unit ~loc:0; + Tezos_micheline.Micheline.strip_locations @@ unit ~loc:(); }) | Tezos_micheline.Micheline.Prim ( _, @@ -876,7 +876,7 @@ let multisig_create_param ~counter ~generic ~action ~optional_signatures () : return @@ some ~loc (String (loc, Signature.to_b58check signature))) optional_signatures >>=? fun l -> - Lwt.return @@ action_to_expr ~loc:0 ~generic action >>=? fun expr -> + Lwt.return @@ action_to_expr ~loc ~generic action >>=? fun expr -> return @@ strip_locations @@ pair ~loc (pair ~loc (int ~loc counter) expr) (Seq (loc, l)) @@ -994,7 +994,7 @@ let check_action (cctxt : #Protocol_client_context.full) ~action ~balance ?gas return_unit | Lambda code -> let action_t = - Tezos_micheline.Micheline.strip_locations (lambda_action_t ~loc:0) + Tezos_micheline.Micheline.strip_locations (lambda_action_t ~loc:()) in trace (Ill_typed_lambda (code, action_t)) @@ Plugin.RPC.Scripts.typecheck_data -- GitLab From a1571e761b9429aab313bb32c2dfa45a1da6e23b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:14:22 +0200 Subject: [PATCH 13/24] Lib_micheline: add dummy_location --- src/lib_micheline/micheline.ml | 2 ++ src/lib_micheline/micheline.mli | 3 +++ 2 files changed, 5 insertions(+) diff --git a/src/lib_micheline/micheline.ml b/src/lib_micheline/micheline.ml index 9700f3167f98..fd7e9a3940ad 100644 --- a/src/lib_micheline/micheline.ml +++ b/src/lib_micheline/micheline.ml @@ -34,6 +34,8 @@ type ('l, 'p) node = type canonical_location = int +let dummy_location = -1 + type 'p canonical = Canonical of (canonical_location, 'p) node let canonical_location_encoding = diff --git a/src/lib_micheline/micheline.mli b/src/lib_micheline/micheline.mli index cd88b4705b69..ea18191bf64d 100644 --- a/src/lib_micheline/micheline.mli +++ b/src/lib_micheline/micheline.mli @@ -71,6 +71,9 @@ type 'p canonical (** Canonical integer locations that appear inside {!canonical} expressions. *) type canonical_location = int +(** A location that won't exist in any well-formed canonical value *) +val dummy_location : canonical_location + (** Encoding for canonical integer locations. *) val canonical_location_encoding : canonical_location Data_encoding.encoding -- GitLab From d7074b9f0b13c80f1fe5da77b146747670d7efe5 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:14:35 +0200 Subject: [PATCH 14/24] EnvV4: add Micheline.dummy_location --- src/lib_protocol_environment/sigs/v4/micheline.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/lib_protocol_environment/sigs/v4/micheline.mli b/src/lib_protocol_environment/sigs/v4/micheline.mli index e47d2eb6dc4c..aa50e3a55f0b 100644 --- a/src/lib_protocol_environment/sigs/v4/micheline.mli +++ b/src/lib_protocol_environment/sigs/v4/micheline.mli @@ -36,6 +36,8 @@ type 'p canonical type canonical_location = int +val dummy_location : canonical_location + val root : 'p canonical -> (canonical_location, 'p) node val canonical_location_encoding : canonical_location Data_encoding.encoding -- GitLab From 689857558d9cc89a92fddb31738f6608126ce02b Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:20:24 +0200 Subject: [PATCH 15/24] Proto: use Micheline.dummy_location --- .../lib_protocol/global_constants_storage.ml | 2 +- .../lib_protocol/script_interpreter_defs.ml | 4 ++-- src/proto_alpha/lib_protocol/script_ir_translator.ml | 10 +++++----- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml index 0db6ec9a48cc..7a7574e07dde 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml @@ -238,7 +238,7 @@ let check_depth node = (* Because [depth] doesn't care about the content of the expression, we can safely throw away information about primitives and replace them with the [Seq] constructor.*) - (Seq (-1, tl)) + (Seq (Micheline.dummy_location, tl)) depth (fun dtl -> (k [@tailcall]) (Compare.Int.max dhd dtl))) in diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index cc100d5f54dd..3ed1d84d2ed6 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -568,7 +568,7 @@ let apply ctxt gas capture_ty capture lam = let (Item_t (full_arg_ty, _, _)) = descr.kbef in let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> - let loc = -1 in + let loc = Micheline.dummy_location in unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> match full_arg_ty with | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _) -> @@ -650,7 +650,7 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = let create_contract (ctxt, sc) gas storage_type param_type code views root_name delegate credit init = let ctxt = update_context gas ctxt in - let loc = -1 in + let loc = Micheline.dummy_location in unparse_ty ~loc ctxt param_type >>?= fun (unparsed_param_type, ctxt) -> let unparsed_param_type = Script_ir_translator.add_field_annot root_name None unparsed_param_type diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 6f74da5cf426..22bfffce1188 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1987,7 +1987,7 @@ let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = | None -> false | Some (Field_annot l) -> Compare.String.(l = entrypoint) in - let loc = -1 in + let loc = Micheline.dummy_location in let rec find_entrypoint : type t. t ty -> string -> ((Script.node -> Script.node) * ex_ty) option = fun t entrypoint -> @@ -4057,7 +4057,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : tc_context ctxt ~legacy - (Seq (-1, tl)) + (Seq (Micheline.dummy_location, tl)) middle >|=? fun (judgement, ctxt) -> let judgement = @@ -5989,7 +5989,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : fail Unparsing_too_many_recursive_calls else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a in - let loc = -1 in + let loc = Micheline.dummy_location in match (ty, a) with | (Unit_t _, v) -> Lwt.return @@ unparse_unit ~loc ctxt v | (Int_t _, v) -> Lwt.return @@ unparse_int ~loc ctxt v @@ -6158,7 +6158,7 @@ and unparse_items : fun ctxt ~stack_depth mode kt vt items -> List.fold_left_es (fun (l, ctxt) (k, v) -> - let loc = -1 in + let loc = Micheline.dummy_location in unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) @@ -6225,7 +6225,7 @@ let unparse_script ctxt mode unparse_data ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> Lwt.return - (let loc = -1 in + (let loc = Micheline.dummy_location in unparse_ty ~loc ctxt arg_type >>? fun (arg_type, ctxt) -> unparse_ty ~loc ctxt storage_type >>? fun (storage_type, ctxt) -> let arg_type = add_field_annot root_name None arg_type in -- GitLab From ed310f1bbdbb0e2dc5791c971bd0f2d6669420cd Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:22:08 +0200 Subject: [PATCH 16/24] Lib_micheline: add is_dummy_location --- src/lib_micheline/micheline.ml | 2 ++ src/lib_micheline/micheline.mli | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/src/lib_micheline/micheline.ml b/src/lib_micheline/micheline.ml index fd7e9a3940ad..1c678ee20719 100644 --- a/src/lib_micheline/micheline.ml +++ b/src/lib_micheline/micheline.ml @@ -36,6 +36,8 @@ type canonical_location = int let dummy_location = -1 +let is_dummy_location loc = loc < 0 + type 'p canonical = Canonical of (canonical_location, 'p) node let canonical_location_encoding = diff --git a/src/lib_micheline/micheline.mli b/src/lib_micheline/micheline.mli index ea18191bf64d..e7778e20de1b 100644 --- a/src/lib_micheline/micheline.mli +++ b/src/lib_micheline/micheline.mli @@ -74,6 +74,10 @@ type canonical_location = int (** A location that won't exist in any well-formed canonical value *) val dummy_location : canonical_location +(** Checks whether a location is dummy, i.e. do not come from a well-formed + canonical value. *) +val is_dummy_location : canonical_location -> bool + (** Encoding for canonical integer locations. *) val canonical_location_encoding : canonical_location Data_encoding.encoding -- GitLab From 9762a355e132313d174488874d03764ff237e348 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:22:38 +0200 Subject: [PATCH 17/24] EnvV4: add Micheline.is_dummy_location --- src/lib_protocol_environment/sigs/v4/micheline.mli | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/lib_protocol_environment/sigs/v4/micheline.mli b/src/lib_protocol_environment/sigs/v4/micheline.mli index aa50e3a55f0b..6e52c7156bdb 100644 --- a/src/lib_protocol_environment/sigs/v4/micheline.mli +++ b/src/lib_protocol_environment/sigs/v4/micheline.mli @@ -38,6 +38,8 @@ type canonical_location = int val dummy_location : canonical_location +val is_dummy_location : canonical_location -> bool + val root : 'p canonical -> (canonical_location, 'p) node val canonical_location_encoding : canonical_location Data_encoding.encoding -- GitLab From 860facf13fa102b75ef2266bc0d02a3854f96c16 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:25:12 +0200 Subject: [PATCH 18/24] Proto: use Micheline.is_dummy_location --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 22bfffce1188..f3ea1a10cd9c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -3076,7 +3076,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in let log_stack ctxt loc stack_ty aft = match (type_logger, script_instr) with - | (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) -> + | (None, _) | (Some _, (Int _ | String _ | Bytes _)) -> Result.return_unit + | (Some _, Seq (loc, _)) when Micheline.is_dummy_location loc -> Result.return_unit | (Some log, (Prim _ | Seq _)) -> (* Unparsing for logging done in an unlimited context as this -- GitLab From bf1b121a59d9b253808bbf52719566576557d1f5 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:34:52 +0200 Subject: [PATCH 19/24] EnvV4: make sure that Micheline.canonical_location type is the same inside and outside the protocol --- src/lib_protocol_environment/environment_V4.ml | 1 + src/lib_protocol_environment/environment_V4.mli | 1 + 2 files changed, 2 insertions(+) diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index b6e62c3bdfbb..a9f06298eb57 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -72,6 +72,7 @@ module type V4 = sig and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t + and type Micheline.canonical_location = Micheline.canonical_location and type 'a Micheline.canonical = 'a Micheline.canonical and type Z.t = Z.t and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node diff --git a/src/lib_protocol_environment/environment_V4.mli b/src/lib_protocol_environment/environment_V4.mli index 1b0ae6ee128f..2764f6a9b6d1 100644 --- a/src/lib_protocol_environment/environment_V4.mli +++ b/src/lib_protocol_environment/environment_V4.mli @@ -71,6 +71,7 @@ module type V4 = sig and type Pvss_secp256k1.Clear_share.t = Pvss_secp256k1.Clear_share.t and type Pvss_secp256k1.Public_key.t = Pvss_secp256k1.Public_key.t and type Pvss_secp256k1.Secret_key.t = Pvss_secp256k1.Secret_key.t + and type Micheline.canonical_location = Micheline.canonical_location and type 'a Micheline.canonical = 'a Micheline.canonical and type Z.t = Z.t and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node -- GitLab From 984ed609e24c6cbb4067b6f3ff20a3ba07d23a56 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Fri, 15 Oct 2021 17:36:55 +0200 Subject: [PATCH 20/24] EnvV4: make Micheline.canonical_location abstract --- src/lib_protocol_environment/sigs/v4/micheline.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib_protocol_environment/sigs/v4/micheline.mli b/src/lib_protocol_environment/sigs/v4/micheline.mli index 6e52c7156bdb..1e2d10fb6f52 100644 --- a/src/lib_protocol_environment/sigs/v4/micheline.mli +++ b/src/lib_protocol_environment/sigs/v4/micheline.mli @@ -34,7 +34,7 @@ type ('l, 'p) node = type 'p canonical -type canonical_location = int +type canonical_location val dummy_location : canonical_location -- GitLab From 04ff3460b2254f7792262f2b7df882690c8bc421 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 14:46:00 +0200 Subject: [PATCH 21/24] Proto/Michelson: move annot types to script_ir_annot from script_typed_ir --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 2 +- src/proto_alpha/lib_protocol/dune.inc | 10 +++++----- src/proto_alpha/lib_protocol/script_ir_annot.ml | 7 ++++++- src/proto_alpha/lib_protocol/script_ir_annot.mli | 7 ++++++- .../lib_protocol/script_ir_translator.mli | 14 +++++++------- src/proto_alpha/lib_protocol/script_typed_ir.ml | 7 +------ src/proto_alpha/lib_protocol/script_typed_ir.mli | 7 +------ .../lib_protocol/script_typed_ir_size.ml | 6 +++--- 8 files changed, 30 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 0f2d2aa13ead..8bea3856638d 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -80,11 +80,11 @@ "Alpha_context", "Script_tc_errors", + "Script_ir_annot", "Script_typed_ir", "Script_typed_ir_size", "Script_typed_ir_size_costs", "Michelson_v1_gas", - "Script_ir_annot", "Script_list", "Script_comparable", "Script_set", diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index c01d88500d16..f6afad710539 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -99,11 +99,11 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end cache_costs.mli cache_costs.ml alpha_context.mli alpha_context.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml @@ -204,11 +204,11 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end cache_costs.mli cache_costs.ml alpha_context.mli alpha_context.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml @@ -309,11 +309,11 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end cache_costs.mli cache_costs.ml alpha_context.mli alpha_context.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml @@ -436,11 +436,11 @@ include Tezos_raw_protocol_alpha.Main Cache_costs Alpha_context Script_tc_errors + Script_ir_annot Script_typed_ir Script_typed_ir_size Script_typed_ir_size_costs Michelson_v1_gas - Script_ir_annot Script_list Script_comparable Script_set @@ -580,11 +580,11 @@ include Tezos_raw_protocol_alpha.Main cache_costs.mli cache_costs.ml alpha_context.mli alpha_context.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 62b996b64418..e69adaa12430 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -26,7 +26,12 @@ open Alpha_context open Micheline open Script_tc_errors -open Script_typed_ir + +type var_annot = Var_annot of string [@@ocaml.unboxed] + +type type_annot = Type_annot of string [@@ocaml.unboxed] + +type field_annot = Field_annot of string [@@ocaml.unboxed] let default_now_annot = Some (Var_annot "now") diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index c19a8389309c..475eb733429a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -24,7 +24,12 @@ (*****************************************************************************) open Alpha_context -open Script_typed_ir + +type var_annot = Var_annot of string [@@ocaml.unboxed] + +type type_annot = Type_annot of string [@@ocaml.unboxed] + +type field_annot = Field_annot of string [@@ocaml.unboxed] (** Default annotations *) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 1a09d615831a..58b239c985f7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -43,7 +43,7 @@ type toplevel = { arg_type : Script.node; storage_type : Script.node; views : Script_typed_ir.view Script_typed_ir.SMap.t; - root_name : Script_typed_ir.field_annot option; + root_name : Script_ir_annot.field_annot option; } type ('arg, 'storage) code = { @@ -56,7 +56,7 @@ type ('arg, 'storage) code = { arg_type : 'arg Script_typed_ir.ty; storage_type : 'storage Script_typed_ir.ty; views : Script_typed_ir.view Script_typed_ir.SMap.t; - root_name : Script_typed_ir.field_annot option; + root_name : Script_ir_annot.field_annot option; code_size : Cache_memory_helpers.sint; (** This is an over-approximation of the value size in memory, in bytes, of the contract's static part, that is its source @@ -93,7 +93,7 @@ type tc_context = | Toplevel : { storage_type : 'sto Script_typed_ir.ty; param_type : 'param Script_typed_ir.ty; - root_name : Script_typed_ir.field_annot option; + root_name : Script_ir_annot.field_annot option; legacy_create_contract_literal : bool; } -> tc_context @@ -338,8 +338,8 @@ val parse_toplevel : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult val add_field_annot : - Script_typed_ir.field_annot option -> - Script_typed_ir.var_annot option -> + Script_ir_annot.field_annot option -> + Script_ir_annot.var_annot option -> ('loc, 'prim) Micheline.node -> ('loc, 'prim) Micheline.node @@ -400,7 +400,7 @@ val parse_contract_for_script : val find_entrypoint : 't Script_typed_ir.ty -> - root_name:Script_typed_ir.field_annot option -> + root_name:Script_ir_annot.field_annot option -> string -> ((Script.node -> Script.node) * ex_ty) tzresult @@ -409,7 +409,7 @@ module Entrypoints_map : Map.S with type key = string val list_entrypoints : 't Script_typed_ir.ty -> context -> - root_name:Script_typed_ir.field_annot option -> + root_name:Script_ir_annot.field_annot option -> (Michelson_v1_primitives.prim list list * (Michelson_v1_primitives.prim list * (unit, Script.prim) Micheline.node) Entrypoints_map.t) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 6e1f9564f4bd..347ce5b989c0 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -26,15 +26,10 @@ open Alpha_context open Script_int +open Script_ir_annot (* Preliminary definitions. *) -type var_annot = Var_annot of string [@@ocaml.unboxed] - -type type_annot = Type_annot of string [@@ocaml.unboxed] - -type field_annot = Field_annot of string [@@ocaml.unboxed] - type never = | type address = Contract.t * string diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 0630dac3f1c2..8013a6a1d9cf 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -26,15 +26,10 @@ open Alpha_context open Script_int +open Script_ir_annot (* Preliminary definitions. *) -type var_annot = Var_annot of string [@@ocaml.unboxed] - -type type_annot = Type_annot of string [@@ocaml.unboxed] - -type field_annot = Field_annot of string [@@ocaml.unboxed] - type never = | type address = Contract.t * string diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 8ad799f46230..84b2bb7922b7 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -33,11 +33,11 @@ let script_string_size s = Script_string.to_string s |> string_size Micheline representation and that the strings are always shared. (One can check that they are never copied.) Besides, the following types are unboxed so that they have no tags. *) -let type_annot_size (Type_annot _) = !!0 +let type_annot_size (Script_ir_annot.Type_annot _) = !!0 -let field_annot_size (Field_annot _) = !!0 +let field_annot_size (Script_ir_annot.Field_annot _) = !!0 -let var_annot_size (Var_annot _) = !!0 +let var_annot_size (Script_ir_annot.Var_annot _) = !!0 (* Memo-sizes are 16-bit integers *) let sapling_memo_size_size = !!0 -- GitLab From 1f8678c9cf74f9d33a9bfc203537e87625071204 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 15:10:13 +0200 Subject: [PATCH 22/24] Proto/Michelson: name lambda arg annot I suppose @ shouldn't have been here but changing it could break existing scripts --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 2 ++ src/proto_alpha/lib_protocol/script_ir_annot.mli | 2 ++ src/proto_alpha/lib_protocol/script_ir_translator.ml | 2 +- 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index e69adaa12430..7770b90fe62e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -51,6 +51,8 @@ let default_self_annot = Some (Var_annot "self") let default_arg_annot = Some (Var_annot "arg") +let lambda_arg_annot = Some (Var_annot "@arg") + let default_param_annot = Some (Var_annot "parameter") let default_storage_annot = Some (Var_annot "storage") diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 475eb733429a..cb3d0c2180bb 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -51,6 +51,8 @@ val default_self_annot : var_annot option val default_arg_annot : var_annot option +val lambda_arg_annot : var_annot option + val default_param_annot : var_annot option val default_storage_annot : var_annot option diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f3ea1a10cd9c..d7b473a6202a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2720,7 +2720,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : ~stack_depth:(stack_depth + 1) ctxt ~legacy - (ta, Some (Var_annot "@arg")) + (ta, lambda_arg_annot) tr script_instr | (Lambda_t _, expr) -> -- GitLab From 1a1a26f3f8b79f8f8163964f3b55a7ecb4e1a678 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 15:13:49 +0200 Subject: [PATCH 23/24] Tests/proto: factorize annot construction --- .../lib_protocol/test/test_typechecking.ml | 66 ++++++++++--------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index 45d4a099cf54..2d448461a8e5 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -206,6 +206,12 @@ let test_parse_ty ctxt node expected = Script_ir_translator.ty_eq ctxt (location node) actual expected >|? fun (_, ctxt) -> ctxt ) +let var_annot s = Script_ir_annot.Var_annot s + +let type_annot s = Script_ir_annot.Type_annot s + +let field_annot s = Script_ir_annot.Field_annot s + let test_parse_comb_type () = let open Script in let open Script_typed_ir in @@ -248,7 +254,7 @@ let test_parse_comb_type () = (* pair (nat %a) nat *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (nat_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_ty -> @@ -258,7 +264,7 @@ let test_parse_comb_type () = pair_t (-1) (nat_ty, None, None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_nat_b_ty -> test_parse_ty ctxt (pair_prim2 nat_prim nat_prim_b) pair_nat_nat_b_ty @@ -266,8 +272,8 @@ let test_parse_comb_type () = (* pair (nat %a) (nat %b) *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_nat_b_ty -> test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim_b) pair_nat_a_nat_b_ty @@ -275,13 +281,13 @@ let test_parse_comb_type () = (* pair (nat %a) (nat %b) (nat %c) *) pair_t (-1) - (nat_ty, Some (Field_annot "b"), None) - (nat_ty, Some (Field_annot "c"), None) + (nat_ty, Some (field_annot "b"), None) + (nat_ty, Some (field_annot "c"), None) ~annot:None >>??= fun pair_nat_b_nat_c_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (pair_nat_b_nat_c_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_b_nat_c_ty -> @@ -295,8 +301,8 @@ let test_parse_comb_type () = >>??= fun pair_b_nat_nat_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (pair_b_nat_nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (pair_b_nat_nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_parse_ty @@ -349,7 +355,7 @@ let test_unparse_comb_type () = (* pair (nat %a) nat *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (nat_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_ty -> @@ -363,7 +369,7 @@ let test_unparse_comb_type () = pair_t (-1) (nat_ty, None, None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_nat_b_ty -> test_unparse_ty @@ -375,8 +381,8 @@ let test_unparse_comb_type () = (* pair (nat %a) (nat %b) *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_nat_b_ty -> test_unparse_ty @@ -388,13 +394,13 @@ let test_unparse_comb_type () = (* pair (nat %a) (nat %b) (nat %c) *) pair_t (-1) - (nat_ty, Some (Field_annot "b"), None) - (nat_ty, Some (Field_annot "c"), None) + (nat_ty, Some (field_annot "b"), None) + (nat_ty, Some (field_annot "c"), None) ~annot:None >>??= fun pair_nat_b_nat_c_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (pair_nat_b_nat_c_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_b_nat_c_ty -> @@ -409,8 +415,8 @@ let test_unparse_comb_type () = >>??= fun pair_nat_nat_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (pair_nat_nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (pair_nat_nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_unparse_ty @@ -423,7 +429,7 @@ let test_unparse_comb_type () = pair_t (-1) (nat_ty, None, None) - (pair_nat_nat_ty, None, Some (Var_annot "b")) + (pair_nat_nat_ty, None, Some (var_annot "b")) ~annot:None >>??= fun pair_nat_pair_b_nat_nat_ty -> test_unparse_ty @@ -437,7 +443,7 @@ let test_unparse_comb_type () = (-1) (nat_ty, None, None) (nat_ty, None, None) - ~annot:(Some (Type_annot "b")) + ~annot:(Some (type_annot "b")) >>??= fun pair_b_nat_nat_ty -> pair_t (-1) (nat_ty, None, None) (pair_b_nat_nat_ty, None, None) ~annot:None >>??= fun pair_nat_pair_b_nat_nat_ty -> @@ -493,7 +499,7 @@ let test_unparse_comb_comparable_type () = pair_nat_nat_nat_ty >>?= fun ctxt -> (* pair (nat %a) nat *) - pair_key (-1) (nat_ty, Some (Field_annot "a")) (nat_ty, None) ~annot:None + pair_key (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) ~annot:None >>??= fun pair_nat_a_nat_ty -> test_unparse_comparable_ty __LOC__ @@ -502,7 +508,7 @@ let test_unparse_comb_comparable_type () = pair_nat_a_nat_ty >>?= fun ctxt -> (* pair nat (nat %b) *) - pair_key (-1) (nat_ty, None) (nat_ty, Some (Field_annot "b")) ~annot:None + pair_key (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) ~annot:None >>??= fun pair_nat_nat_b_ty -> test_unparse_comparable_ty __LOC__ @@ -513,8 +519,8 @@ let test_unparse_comb_comparable_type () = (* pair (nat %a) (nat %b) *) pair_key (-1) - (nat_ty, Some (Field_annot "a")) - (nat_ty, Some (Field_annot "b")) + (nat_ty, Some (field_annot "a")) + (nat_ty, Some (field_annot "b")) ~annot:None >>??= fun pair_nat_a_nat_b_ty -> test_unparse_comparable_ty @@ -526,13 +532,13 @@ let test_unparse_comb_comparable_type () = (* pair (nat %a) (nat %b) (nat %c) *) pair_key (-1) - (nat_ty, Some (Field_annot "b")) - (nat_ty, Some (Field_annot "c")) + (nat_ty, Some (field_annot "b")) + (nat_ty, Some (field_annot "c")) ~annot:None >>??= fun pair_nat_b_nat_c_ty -> pair_key (-1) - (nat_ty, Some (Field_annot "a")) + (nat_ty, Some (field_annot "a")) (pair_nat_b_nat_c_ty, None) ~annot:None >>??= fun pair_nat_a_nat_b_nat_c_ty -> @@ -545,8 +551,8 @@ let test_unparse_comb_comparable_type () = (* pair (nat %a) (pair %b nat nat) *) pair_key (-1) - (nat_ty, Some (Field_annot "a")) - (pair_nat_nat_ty, Some (Field_annot "b")) + (nat_ty, Some (field_annot "a")) + (pair_nat_nat_ty, Some (field_annot "b")) ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_unparse_comparable_ty @@ -556,7 +562,7 @@ let test_unparse_comb_comparable_type () = pair_nat_a_pair_b_nat_nat_ty >>?= fun ctxt -> (* pair nat (pair :b nat nat) *) - pair_key (-1) (nat_ty, None) (nat_ty, None) ~annot:(Some (Type_annot "b")) + pair_key (-1) (nat_ty, None) (nat_ty, None) ~annot:(Some (type_annot "b")) >>??= fun pair_b_nat_nat_ty -> pair_key (-1) (nat_ty, None) (pair_b_nat_nat_ty, None) ~annot:None >>??= fun pair_nat_pair_b_nat_nat_ty -> -- GitLab From 39febdb9a4724d48401e824e33640cac1da135a2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 15:14:33 +0200 Subject: [PATCH 24/24] Proto/Michelson: make annot types private --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 8 ++++++++ src/proto_alpha/lib_protocol/script_ir_annot.mli | 14 +++++++++++--- .../lib_protocol/test/test_typechecking.ml | 6 +++--- 3 files changed, 22 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 7770b90fe62e..2f246df481c9 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -33,6 +33,14 @@ type type_annot = Type_annot of string [@@ocaml.unboxed] type field_annot = Field_annot of string [@@ocaml.unboxed] +module FOR_TESTS = struct + let unsafe_var_annot_of_string s = Var_annot s + + let unsafe_type_annot_of_string s = Type_annot s + + let unsafe_field_annot_of_string s = Field_annot s +end + let default_now_annot = Some (Var_annot "now") let default_amount_annot = Some (Var_annot "amount") diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index cb3d0c2180bb..f043bda2cbab 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -25,11 +25,19 @@ open Alpha_context -type var_annot = Var_annot of string [@@ocaml.unboxed] +type var_annot = private Var_annot of string [@@ocaml.unboxed] -type type_annot = Type_annot of string [@@ocaml.unboxed] +type type_annot = private Type_annot of string [@@ocaml.unboxed] -type field_annot = Field_annot of string [@@ocaml.unboxed] +type field_annot = private Field_annot of string [@@ocaml.unboxed] + +module FOR_TESTS : sig + val unsafe_var_annot_of_string : string -> var_annot + + val unsafe_type_annot_of_string : string -> type_annot + + val unsafe_field_annot_of_string : string -> field_annot +end (** Default annotations *) diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index 2d448461a8e5..84de9dfb0436 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -206,11 +206,11 @@ let test_parse_ty ctxt node expected = Script_ir_translator.ty_eq ctxt (location node) actual expected >|? fun (_, ctxt) -> ctxt ) -let var_annot s = Script_ir_annot.Var_annot s +let var_annot = Script_ir_annot.FOR_TESTS.unsafe_var_annot_of_string -let type_annot s = Script_ir_annot.Type_annot s +let type_annot = Script_ir_annot.FOR_TESTS.unsafe_type_annot_of_string -let field_annot s = Script_ir_annot.Field_annot s +let field_annot = Script_ir_annot.FOR_TESTS.unsafe_field_annot_of_string let test_parse_comb_type () = let open Script in -- GitLab