From eef5885265424c88f51061bd1aed0940be47dfd1 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Sat, 24 Mar 2018 12:26:46 +0100 Subject: [PATCH] Alpha, Michelson: no need to thread the gas in parsing linear structures --- src/proto_alpha/lib_protocol/src/apply.ml | 2 +- .../lib_protocol/src/helpers_services.ml | 2 +- .../lib_protocol/src/script_ir_translator.ml | 336 +++++++++--------- .../lib_protocol/src/script_ir_translator.mli | 6 +- .../src/script_tc_errors_registration.ml | 10 +- 5 files changed, 168 insertions(+), 188 deletions(-) diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index 3c9c68f5c..a59fe3538 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -407,7 +407,7 @@ let apply_manager_operation_content return (ctxt, origination_nonce, None) | Error err -> return (ctxt, origination_nonce, Some err) in - Lwt.return @@ Script_ir_translator.parse_toplevel ctxt script.code >>=? fun ((arg_type, _, _, _), ctxt) -> + Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _, _) -> let arg_type = Micheline.strip_locations arg_type in match parameters, Micheline.root arg_type with | None, Prim (_, T_unit, _, _) -> diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index ca96dfdf1..8308593a7 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -221,7 +221,7 @@ let () = let ctxt = match maybe_gas with | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in - Lwt.return (parse_ty ctxt false (Micheline.root typ)) >>=? fun ((Ex_ty typ, _), ctxt) -> + Lwt.return (parse_ty false (Micheline.root typ)) >>=? fun (Ex_ty typ, _) -> parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> Lwt.return (Script_ir_translator.hash_data ctxt typ data) >>=? fun (hash, ctxt) -> return (hash, Gas.level ctxt) diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index d8e63e72f..c772e3cba 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -893,138 +893,122 @@ let merge_branches module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking -let rec parse_comparable_ty : context -> Script.node -> (ex_comparable_ty * context) tzresult = fun ctxt node -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - match node with - | Prim (_, T_int, [], _) -> ok ((Ex_comparable_ty Int_key), ctxt) - | Prim (_, T_nat, [], _) -> ok ((Ex_comparable_ty Nat_key), ctxt) - | Prim (_, T_string, [], _) -> ok ((Ex_comparable_ty String_key), ctxt) - | Prim (_, T_tez, [], _) -> ok ((Ex_comparable_ty Tez_key), ctxt) - | Prim (_, T_bool, [], _) -> ok ((Ex_comparable_ty Bool_key), ctxt) - | Prim (_, T_key_hash, [], _) -> ok ((Ex_comparable_ty Key_hash_key), ctxt) - | Prim (_, T_timestamp, [], _) -> ok ((Ex_comparable_ty Timestamp_key), ctxt) - | Prim (loc, (T_int | T_nat - | T_string | T_tez | T_bool - | T_key | T_timestamp as prim), l, _) -> - error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, (T_pair | T_or | T_set | T_map - | T_list | T_option | T_lambda - | T_unit | T_signature | T_contract), _, _) as expr -> - parse_ty ctxt false expr >>? fun ((Ex_ty ty, _), _ctxt) -> - error (Comparable_type_expected (loc, ty)) - | expr -> - error @@ unexpected expr [] Type_namespace - [ T_int ; T_nat ; - T_string ; T_tez ; T_bool ; - T_key ; T_key_hash ; T_timestamp ] +let rec parse_comparable_ty + : Script.node -> ex_comparable_ty tzresult + = function + | Prim (_, T_int, [], _) -> ok (Ex_comparable_ty Int_key) + | Prim (_, T_nat, [], _) -> ok (Ex_comparable_ty Nat_key) + | Prim (_, T_string, [], _) -> ok (Ex_comparable_ty String_key) + | Prim (_, T_tez, [], _) -> ok (Ex_comparable_ty Tez_key) + | Prim (_, T_bool, [], _) -> ok (Ex_comparable_ty Bool_key) + | Prim (_, T_key_hash, [], _) -> ok (Ex_comparable_ty Key_hash_key) + | Prim (_, T_timestamp, [], _) -> ok (Ex_comparable_ty Timestamp_key) + | Prim (loc, (T_int | T_nat + | T_string | T_tez | T_bool + | T_key | T_timestamp as prim), l, _) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim (loc, (T_pair | T_or | T_set | T_map + | T_list | T_option | T_lambda + | T_unit | T_signature | T_contract), _, _) as expr -> + parse_ty false expr >>? fun (Ex_ty ty, _) -> + error (Comparable_type_expected (loc, ty)) + | expr -> + error @@ unexpected expr [] Type_namespace + [ T_int ; T_nat ; + T_string ; T_tez ; T_bool ; + T_key ; T_key_hash ; T_timestamp ] -and parse_ty : - context -> bool -> Script.node -> - ((ex_ty * annot) * context) tzresult = fun ctxt big_map_possible node -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> - match node with - | Prim (_, T_pair, - [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], - storage_annot) - when big_map_possible -> - begin match args with - | [ key_ty ; value_ty ] -> - parse_comparable_ty ctxt key_ty >>? fun ((Ex_comparable_ty key_ty), gas) -> - parse_ty gas false value_ty >>? fun ((Ex_ty value_ty, right_annot), gas) -> - error_unexpected_annot big_map_loc right_annot >>? fun () -> - parse_ty gas false remaining_storage >>? fun ((Ex_ty remaining_storage, remaining_annot), gas) -> - ok ((Ex_ty (Pair_t ((Big_map_t (key_ty, value_ty), map_annot), - (remaining_storage, remaining_annot))), - storage_annot), - gas) - | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) - end - | Prim (_, T_unit, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Unit_t, annot), ctxt) - | Prim (_, T_int, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Int_t, annot), ctxt) - | Prim (_, T_nat, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Nat_t, annot), ctxt) - | Prim (_, T_string, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty String_t, annot), ctxt) - | Prim (_, T_tez, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Tez_t, annot), ctxt) - | Prim (_, T_bool, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Bool_t, annot), ctxt) - | Prim (_, T_key, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Key_t, annot), ctxt) - | Prim (_, T_key_hash, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Key_hash_t, annot), ctxt) - | Prim (_, T_timestamp, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Timestamp_t, annot), ctxt) - | Prim (_, T_signature, [], annot) -> - Gas.consume ctxt Typecheck_costs.primitive_type >>? fun ctxt -> - ok ((Ex_ty Signature_t, annot), ctxt) - | Prim (loc, T_contract, [ utl; utr ], annot) -> - Gas.consume ctxt Typecheck_costs.two_arg_type >>? fun ctxt -> - parse_ty ctxt false utl >>? fun ((Ex_ty tl, left_annot), ctxt) -> - parse_ty ctxt false utr >>? fun ((Ex_ty tr, right_annot), ctxt) -> - error_unexpected_annot loc left_annot >>? fun () -> - error_unexpected_annot loc right_annot >|? fun () -> - ((Ex_ty (Contract_t (tl, tr)), annot), ctxt) - | Prim (_, T_pair, [ utl; utr ], annot) -> - parse_ty ctxt false utl >>? fun ((Ex_ty tl, left_annot), ctxt) -> - parse_ty ctxt false utr >|? fun ((Ex_ty tr, right_annot), ctxt) -> - ((Ex_ty (Pair_t ((tl, left_annot), (tr, right_annot))), annot), ctxt) - | Prim (_, T_or, [ utl; utr ], annot) -> - parse_ty ctxt false utl >>? fun ((Ex_ty tl, left_annot), ctxt) -> - parse_ty ctxt false utr >|? fun ((Ex_ty tr, right_annot), ctxt) -> - ((Ex_ty (Union_t ((tl, left_annot), (tr, right_annot))), annot), ctxt) - | Prim (_, T_lambda, [ uta; utr ], annot) -> - parse_ty ctxt false uta >>? fun ((Ex_ty ta, _), ctxt) -> - parse_ty ctxt false utr >|? fun ((Ex_ty tr, _), ctxt) -> - ((Ex_ty (Lambda_t (ta, tr)), annot), ctxt) - | Prim (loc, T_option, [ ut ], annot) -> - parse_ty ctxt false ut >>? fun ((Ex_ty t, opt_annot), ctxt) -> - error_unexpected_annot loc annot >|? fun () -> - ((Ex_ty (Option_t t), opt_annot), ctxt) - | Prim (loc, T_list, [ ut ], annot) -> - Gas.consume ctxt Typecheck_costs.one_arg_type >>? fun ctxt -> - parse_ty ctxt false ut >>? fun ((Ex_ty t, list_annot), ctxt) -> - error_unexpected_annot loc list_annot >>? fun () -> - ok ((Ex_ty (List_t t), annot), ctxt) - | Prim (_, T_set, [ ut ], annot) -> - Gas.consume ctxt Typecheck_costs.one_arg_type >>? fun ctxt -> - parse_comparable_ty ctxt ut >>? fun ((Ex_comparable_ty t), ctxt) -> - ok ((Ex_ty (Set_t t), annot), ctxt) - | Prim (_, T_map, [ uta; utr ], annot) -> - Gas.consume ctxt Typecheck_costs.one_arg_type >>? fun ctxt -> - parse_comparable_ty ctxt uta >>? fun ((Ex_comparable_ty ta), ctxt) -> - parse_ty ctxt false utr >>? fun ((Ex_ty tr, _), ctxt) -> - ok ((Ex_ty (Map_t (ta, tr)), annot), ctxt) - | Prim (loc, T_big_map, _, _) -> - error (Unexpected_big_map loc) - | Prim (loc, (T_unit | T_signature - | T_int | T_nat - | T_string | T_tez | T_bool - | T_key | T_key_hash | T_timestamp as prim), l, _) -> - error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, (T_set | T_list | T_option as prim), l, _) -> - error (Invalid_arity (loc, prim, 1, List.length l)) - | Prim (loc, (T_pair | T_or | T_map | T_lambda | T_contract as prim), l, _) -> - error (Invalid_arity (loc, prim, 2, List.length l)) - | expr -> - error @@ unexpected expr [] Type_namespace - [ T_pair ; T_or ; T_set ; T_map ; - T_list ; T_option ; T_lambda ; - T_unit ; T_signature ; T_contract ; - T_int ; T_nat ; - T_string ; T_tez ; T_bool ; - T_key ; T_key_hash ; T_timestamp ] +and parse_ty + : bool -> Script.node -> (ex_ty * annot) tzresult + = fun big_map_possible node -> + match node with + | Prim (_, T_pair, + [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], + storage_annot) + when big_map_possible -> + begin match args with + | [ key_ty ; value_ty ] -> + parse_comparable_ty key_ty >>? fun (Ex_comparable_ty key_ty) -> + parse_ty false value_ty >>? fun (Ex_ty value_ty, right_annot) -> + error_unexpected_annot big_map_loc right_annot >>? fun () -> + parse_ty false remaining_storage >>? fun (Ex_ty remaining_storage, remaining_annot) -> + ok (Ex_ty (Pair_t ((Big_map_t (key_ty, value_ty), map_annot), + (remaining_storage, remaining_annot))), + storage_annot) + | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) + end + | Prim (_, T_unit, [], annot) -> + ok (Ex_ty Unit_t, annot) + | Prim (_, T_int, [], annot) -> + ok (Ex_ty Int_t, annot) + | Prim (_, T_nat, [], annot) -> + ok (Ex_ty Nat_t, annot) + | Prim (_, T_string, [], annot) -> + ok (Ex_ty String_t, annot) + | Prim (_, T_tez, [], annot) -> + ok (Ex_ty Tez_t, annot) + | Prim (_, T_bool, [], annot) -> + ok (Ex_ty Bool_t, annot) + | Prim (_, T_key, [], annot) -> + ok (Ex_ty Key_t, annot) + | Prim (_, T_key_hash, [], annot) -> + ok (Ex_ty Key_hash_t, annot) + | Prim (_, T_timestamp, [], annot) -> + ok (Ex_ty Timestamp_t, annot) + | Prim (_, T_signature, [], annot) -> + ok (Ex_ty Signature_t, annot) + | Prim (loc, T_contract, [ utl; utr ], annot) -> + parse_ty false utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty false utr >>? fun (Ex_ty tr, right_annot) -> + error_unexpected_annot loc left_annot >>? fun () -> + error_unexpected_annot loc right_annot >|? fun () -> + (Ex_ty (Contract_t (tl, tr)), annot) + | Prim (_, T_pair, [ utl; utr ], annot) -> + parse_ty false utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty false utr >|? fun (Ex_ty tr, right_annot) -> + (Ex_ty (Pair_t ((tl, left_annot), (tr, right_annot))), annot) + | Prim (_, T_or, [ utl; utr ], annot) -> + parse_ty false utl >>? fun (Ex_ty tl, left_annot) -> + parse_ty false utr >|? fun (Ex_ty tr, right_annot) -> + (Ex_ty (Union_t ((tl, left_annot), (tr, right_annot))), annot) + | Prim (_, T_lambda, [ uta; utr ], annot) -> + parse_ty false uta >>? fun (Ex_ty ta, _) -> + parse_ty false utr >|? fun (Ex_ty tr, _) -> + (Ex_ty (Lambda_t (ta, tr)), annot) + | Prim (loc, T_option, [ ut ], annot) -> + parse_ty false ut >>? fun (Ex_ty t, opt_annot) -> + error_unexpected_annot loc annot >|? fun () -> + (Ex_ty (Option_t t), opt_annot) + | Prim (loc, T_list, [ ut ], annot) -> + parse_ty false ut >>? fun (Ex_ty t, list_annot) -> + error_unexpected_annot loc list_annot >>? fun () -> + ok (Ex_ty (List_t t), annot) + | Prim (_, T_set, [ ut ], annot) -> + parse_comparable_ty ut >>? fun (Ex_comparable_ty t) -> + ok (Ex_ty (Set_t t), annot) + | Prim (_, T_map, [ uta; utr ], annot) -> + parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) -> + parse_ty false utr >>? fun (Ex_ty tr, _) -> + ok (Ex_ty (Map_t (ta, tr)), annot) + | Prim (loc, T_big_map, _, _) -> + error (Unexpected_big_map loc) + | Prim (loc, (T_unit | T_signature + | T_int | T_nat + | T_string | T_tez | T_bool + | T_key | T_key_hash | T_timestamp as prim), l, _) -> + error (Invalid_arity (loc, prim, 0, List.length l)) + | Prim (loc, (T_set | T_list | T_option as prim), l, _) -> + error (Invalid_arity (loc, prim, 1, List.length l)) + | Prim (loc, (T_pair | T_or | T_map | T_lambda | T_contract as prim), l, _) -> + error (Invalid_arity (loc, prim, 2, List.length l)) + | expr -> + error @@ unexpected expr [] Type_namespace + [ T_pair ; T_or ; T_set ; T_map ; + T_list ; T_option ; T_lambda ; + T_unit ; T_signature ; T_contract ; + T_int ; T_nat ; + T_string ; T_tez ; T_bool ; + T_key ; T_key_hash ; T_timestamp ] let rec unparse_stack : type a. a stack_ty -> Script.expr list @@ -1367,7 +1351,7 @@ and parse_instr (Item_t (w, Item_t (v, rest, cur_top_annot), annot)) | Prim (loc, I_PUSH, [ t ; d ], instr_annot), stack -> - (Lwt.return (parse_ty ctxt false t)) >>=? fun ((Ex_ty t, _), ctxt) -> + (Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) -> parse_data ?type_logger ctxt t d >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, instr_annot)) @@ -1382,7 +1366,7 @@ and parse_instr (Item_t (Option_t t, rest, instr_annot)) | Prim (loc, I_NONE, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty ctxt false t)) >>=? fun ((Ex_ty t, _), ctxt) -> + (Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) -> typed ctxt loc (Cons_none t) (Item_t (Option_t t, stack, instr_annot)) | Prim (loc, I_IF_NONE, [ bt ; bf ], instr_annot), @@ -1413,12 +1397,12 @@ and parse_instr (* unions *) | Prim (loc, I_LEFT, [ tr ], instr_annot), Item_t (tl, rest, stack_annot) -> - (Lwt.return (parse_ty ctxt false tr)) >>=? fun ((Ex_ty tr, _), ctxt) -> + (Lwt.return (parse_ty false tr)) >>=? fun (Ex_ty tr, _) -> typed ctxt loc Left (Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot)) | Prim (loc, I_RIGHT, [ tl ], instr_annot), Item_t (tr, rest, stack_annot) -> - (Lwt.return (parse_ty ctxt false tl)) >>=? fun ((Ex_ty tl, _), ctxt) -> + (Lwt.return (parse_ty false tl)) >>=? fun (Ex_ty tl, _) -> typed ctxt loc Right (Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot)) | Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot), @@ -1435,7 +1419,7 @@ and parse_instr (* lists *) | Prim (loc, I_NIL, [ t ], instr_annot), stack -> - (Lwt.return (parse_ty ctxt false t)) >>=? fun ((Ex_ty t, _), ctxt) -> + (Lwt.return (parse_ty false t)) >>=? fun (Ex_ty t, _) -> typed ctxt loc Nil (Item_t (List_t t, stack, instr_annot)) | Prim (loc, I_CONS, [], instr_annot), @@ -1502,7 +1486,7 @@ and parse_instr (* sets *) | Prim (loc, I_EMPTY_SET, [ t ], instr_annot), rest -> - (Lwt.return (parse_comparable_ty ctxt t)) >>=? fun ((Ex_comparable_ty t), ctxt) -> + (Lwt.return (parse_comparable_ty t)) >>=? fun (Ex_comparable_ty t) -> typed ctxt loc (Empty_set t) (Item_t (Set_t t, rest, instr_annot)) | Prim (loc, I_REDUCE, [], instr_annot), @@ -1548,8 +1532,8 @@ and parse_instr (* maps *) | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], instr_annot), stack -> - (Lwt.return (parse_comparable_ty ctxt tk)) >>=? fun ((Ex_comparable_ty tk), ctxt) -> - (Lwt.return (parse_ty ctxt false tv)) >>=? fun ((Ex_ty tv, _), ctxt) -> + (Lwt.return (parse_comparable_ty tk)) >>=? fun (Ex_comparable_ty tk) -> + (Lwt.return (parse_ty false tv)) >>=? fun (Ex_ty tv, _) -> typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv), stack, instr_annot)) | Prim (loc, I_MAP, [], instr_annot), @@ -1709,8 +1693,8 @@ and parse_instr end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot), stack -> - (Lwt.return (parse_ty ctxt false arg)) >>=? fun ((Ex_ty arg, arg_annot), ctxt) -> - (Lwt.return (parse_ty ctxt false ret)) >>=? fun ((Ex_ty ret, _), ctxt) -> + (Lwt.return (parse_ty false arg)) >>=? fun (Ex_ty arg, arg_annot) -> + (Lwt.return (parse_ty false ret)) >>=? fun (Ex_ty ret, _) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_returning Lambda ?type_logger ctxt (arg, default_annot ~default:default_arg_annot arg_annot) @@ -2020,16 +2004,16 @@ and parse_instr (ginit, rest, _), _), _), _), _), _) -> fail_unexpected_annot seq_loc annot >>=? fun () -> let cannonical_code = fst @@ Micheline.extract_locations code in - Lwt.return (parse_toplevel ctxt cannonical_code) >>=? fun ((arg_type, ret_type, storage_type, code_field), ctxt) -> + Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> trace (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return (parse_ty ctxt false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), ctxt) -> + (Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "return", cannonical_code, location ret_type)) - (Lwt.return (parse_ty ctxt false ret_type)) >>=? fun ((Ex_ty ret_type, _), ctxt) -> + (Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) -> trace (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return (parse_ty ctxt true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), ctxt) -> + (Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in @@ -2074,8 +2058,8 @@ and parse_instr (Item_t (Nat_t, stack, instr_annot)) | Prim (loc, I_SOURCE, [ ta; tb ], instr_annot), stack -> - (Lwt.return (parse_ty ctxt false ta)) >>=? fun ((Ex_ty ta, _), ctxt) -> - (Lwt.return (parse_ty ctxt false tb)) >>=? fun ((Ex_ty tb, _), ctxt) -> + (Lwt.return (parse_ty false ta)) >>=? fun (Ex_ty ta, _) -> + (Lwt.return (parse_ty false tb)) >>=? fun (Ex_ty tb, _) -> typed ctxt loc (Source (ta, tb)) (Item_t (Contract_t (ta, tb), stack, instr_annot)) | Prim (loc, I_SELF, [], instr_annot), @@ -2198,9 +2182,9 @@ and parse_contract ok (contract, ctxt)) | Some { code ; _ } -> Lwt.return - (parse_toplevel ctxt code >>? fun ((arg_type, ret_type, _, _), ctxt) -> - parse_ty ctxt false arg_type >>? fun ((Ex_ty targ, _), ctxt) -> - parse_ty ctxt false ret_type >>? fun ((Ex_ty tret, _), ctxt) -> + (parse_toplevel code >>? fun (arg_type, ret_type, _, _) -> + parse_ty false arg_type >>? fun (Ex_ty targ, _) -> + parse_ty false ret_type >>? fun (Ex_ty tret, _) -> ty_eq targ arg >>? fun Eq -> ty_eq tret ret >>? fun Eq -> let contract : (arg, ret) typed_contract = @@ -2208,39 +2192,37 @@ and parse_contract ok (contract, ctxt)) and parse_toplevel - : context -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * context) tzresult - = fun ctxt toplevel -> - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + : Script.expr -> (Script.node * Script.node * Script.node * Script.node) tzresult + = fun toplevel -> match root toplevel with | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind)) | Seq (_, fields, _) -> - let rec find_fields ctxt p r s c fields = - Gas.consume ctxt Typecheck_costs.cycle >>? fun ctxt -> + let rec find_fields p r s c fields = match fields with - | [] -> ok ((p, r, s, c), ctxt) + | [] -> ok (p, r, s, c) | Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind)) | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) | Seq (loc, _, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) | Prim (loc, K_parameter, [ arg ], _) :: rest -> begin match p with - | None -> find_fields ctxt (Some arg) r s c rest + | None -> find_fields (Some arg) r s c rest | Some _ -> error (Duplicate_field (loc, K_parameter)) end | Prim (loc, K_return, [ arg ], _) :: rest -> begin match r with - | None -> find_fields ctxt p (Some arg) s c rest + | None -> find_fields p (Some arg) s c rest | Some _ -> error (Duplicate_field (loc, K_return)) end | Prim (loc, K_storage, [ arg ], _) :: rest -> begin match s with - | None -> find_fields ctxt p r (Some arg) c rest + | None -> find_fields p r (Some arg) c rest | Some _ -> error (Duplicate_field (loc, K_storage)) end | Prim (loc, K_code, [ arg ], _) :: rest -> begin match c with - | None -> find_fields ctxt p r s (Some arg) rest + | None -> find_fields p r s (Some arg) rest | Some _ -> error (Duplicate_field (loc, K_code)) end | Prim (loc, (K_parameter | K_return | K_storage | K_code as name), args, _) :: _ -> @@ -2249,27 +2231,27 @@ and parse_toplevel let allowed = [ K_parameter ; K_return ; K_storage ; K_code ] in error (Invalid_primitive (loc, allowed, name)) in - find_fields ctxt None None None None fields >>? function - | ((None, _, _, _), _ctxt) -> error (Missing_field K_parameter) - | ((Some _, None, _, _), _ctxt) -> error (Missing_field K_return) - | ((Some _, Some _, None, _), _ctxt) -> error (Missing_field K_storage) - | ((Some _, Some _, Some _, None), _ctxt) -> error (Missing_field K_code) - | ((Some p, Some r, Some s, Some c), ctxt) -> ok ((p, r, s, c), ctxt) + find_fields None None None None fields >>? function + | (None, _, _, _) -> error (Missing_field K_parameter) + | (Some _, None, _, _) -> error (Missing_field K_return) + | (Some _, Some _, None, _) -> error (Missing_field K_storage) + | (Some _, Some _, Some _, None) -> error (Missing_field K_code) + | (Some p, Some r, Some s, Some c) -> ok (p, r, s, c) let parse_script : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> context -> Script.t -> (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt { code ; storage } -> - Lwt.return (parse_toplevel ctxt code) >>=? fun ((arg_type, ret_type, storage_type, code_field), ctxt) -> + Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ctxt false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), ctxt) -> + (Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "return", code, location ret_type)) - (Lwt.return (parse_ty ctxt false ret_type)) >>=? fun ((Ex_ty ret_type, _), ctxt) -> + (Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty ctxt true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), ctxt) -> + (Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in @@ -2285,18 +2267,18 @@ let parse_script let typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t = fun ctxt code -> - Lwt.return (parse_toplevel ctxt code) >>=? fun ((arg_type, ret_type, storage_type, code_field), ctxt) -> + Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> let type_map = ref [] in (* TODO: annotation checking *) trace (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ctxt false arg_type)) >>=? fun ((Ex_ty arg_type, param_annot), ctxt) -> + (Lwt.return (parse_ty false arg_type)) >>=? fun (Ex_ty arg_type, param_annot) -> trace (Ill_formed_type (Some "return", code, location ret_type)) - (Lwt.return (parse_ty ctxt false ret_type)) >>=? fun ((Ex_ty ret_type, _), ctxt) -> + (Lwt.return (parse_ty false ret_type)) >>=? fun (Ex_ty ret_type, _) -> trace (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty ctxt true storage_type)) >>=? fun ((Ex_ty storage_type, storage_annot), ctxt) -> + (Lwt.return (parse_ty true storage_type)) >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in let ret_type_full = Pair_t ((ret_type, None), (storage_type, None)) in @@ -2317,7 +2299,7 @@ let typecheck_data = fun ?type_logger ctxt (data, exp_ty) -> trace (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return (parse_ty ctxt true (root exp_ty))) >>=? fun ((Ex_ty exp_ty, _), ctxt) -> + (Lwt.return (parse_ty true (root exp_ty))) >>=? fun (Ex_ty exp_ty, _) -> trace (Ill_typed_data (None, data, exp_ty)) (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> @@ -2397,8 +2379,8 @@ let to_printable_big_map ctxt (Ex_bm { diff ; key_type ; value_type }) = Option.map ~f:(fun x -> Micheline.strip_locations @@ unparse value_type x) value) :: acc)) [] pairs let erase_big_map_initialization ctxt ({ code ; storage } : Script.t) = - Lwt.return @@ parse_toplevel ctxt code >>=? fun ((_, _, storage_type, _), ctxt) -> - Lwt.return @@ parse_ty ctxt true storage_type >>=? fun ((Ex_ty ty, _), ctxt) -> + Lwt.return @@ parse_toplevel code >>=? fun (_, _, storage_type, _) -> + Lwt.return @@ parse_ty true storage_type >>=? fun (Ex_ty ty, _) -> parse_data ctxt ty (Micheline.root storage) >>=? fun (storage, ctxt) -> begin match extract_big_map ty storage with diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli index 863035ba8..b23a028af 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -62,13 +62,13 @@ val unparse_data : context -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult val parse_ty : - context -> bool -> Script.node -> - ((ex_ty * Script_typed_ir.annot) * context) tzresult + bool -> Script.node -> + (ex_ty * Script_typed_ir.annot) tzresult val unparse_ty : string option -> 'a Script_typed_ir.ty -> Script.node val parse_toplevel - : context -> Script.expr -> ((Script.node * Script.node * Script.node * Script.node) * context) tzresult + : Script.expr -> (Script.node * Script.node * Script.node * Script.node) tzresult val typecheck_code : context -> Script.expr -> (type_map * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml index a6ccc4acf..3d3a6cea7 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml @@ -29,12 +29,10 @@ let type_map_enc = let ex_ty_enc = Data_encoding.conv (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) - (fun _expr -> - (* (* code temporarily deactivated *) - match parse_ty (Gas.of_int 10000000000) true (root expr) with - | Ok ((Ex_ty ty, _), _) -> Ex_ty ty - | _ -> *) - Ex_ty Unit_t (* FIXME: ? *)) + (fun expr -> + match parse_ty true (root expr) with + | Ok (Ex_ty ty, _) -> Ex_ty ty + | _ -> assert false) Script.expr_encoding (* main registration *)