From a69333d21ffe53a421f1309dc46ca1b403b4c81b Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 27 Jun 2018 12:39:28 +0200 Subject: [PATCH] Alpha, Gas: gas accounting for serialization of data and types Also gas accounting in errors, failures and trace --- .../lib_client/michelson_v1_error_reporter.ml | 45 +- .../lib_protocol/src/helpers_services.ml | 2 +- .../lib_protocol/src/michelson_v1_gas.ml | 34 +- .../lib_protocol/src/michelson_v1_gas.mli | 6 +- .../lib_protocol/src/script_interpreter.ml | 54 +- .../lib_protocol/src/script_interpreter.mli | 3 + .../lib_protocol/src/script_ir_translator.ml | 709 +++++++++++------- .../lib_protocol/src/script_ir_translator.mli | 10 +- .../lib_protocol/src/script_tc_errors.ml | 31 +- .../src/script_tc_errors_registration.ml | 151 ++-- 10 files changed, 598 insertions(+), 447 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index dd5804c1f..ebe31b24c 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -10,39 +10,32 @@ open Proto_alpha open Alpha_context open Tezos_micheline -open Script_typed_ir open Script_tc_errors -open Script_ir_annot -open Script_ir_translator open Script_interpreter open Michelson_v1_printer -let print_ty (type t) ppf (ty : t ty) = - unparse_ty ty - |> Micheline.strip_locations - |> Michelson_v1_printer.print_expr_unwrapped ppf +let print_ty ppf ty = + Michelson_v1_printer.print_expr_unwrapped ppf ty let print_var_annot ppf annot = - List.iter (Format.fprintf ppf "@ %s") (unparse_var_annot annot) + List.iter (Format.fprintf ppf "@ %s") annot -let print_stack_ty (type t) ?(depth = max_int) ppf (s : t stack_ty) = - let rec loop - : type t. int -> Format.formatter -> t stack_ty -> unit - = fun depth ppf -> function - | Empty_t -> () - | _ when depth <= 0 -> - Format.fprintf ppf "..." - | Item_t (last, Empty_t, annot) -> - Format.fprintf ppf "%a%a" - print_ty last - print_var_annot annot - | Item_t (last, rest, annot) -> - Format.fprintf ppf "%a%a@ :@ %a" - print_ty last - print_var_annot annot - (loop (depth - 1)) rest in +let print_stack_ty ?(depth = max_int) ppf s = + let rec loop depth ppf = function + | [] -> () + | _ when depth <= 0 -> + Format.fprintf ppf "..." + | [last, annot] -> + Format.fprintf ppf "%a%a" + print_ty last + print_var_annot annot + | (last, annot) :: rest -> + Format.fprintf ppf "%a%a@ :@ %a" + print_ty last + print_var_annot annot + (loop (depth - 1)) rest in match s with - | Empty_t -> + | [] -> Format.fprintf ppf "[]" | sty -> Format.fprintf ppf "@[[ %a ]@]" (loop depth) sty @@ -338,7 +331,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = - @[expected return stack type:@ %a,@]@,\ - @[actual stack type:@ %a.@]@]" print_loc loc - (fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t, None)) + (fun ppf -> print_stack_ty ppf) [exp, []] (fun ppf -> print_stack_ty ppf) got | Bad_stack (loc, name, depth, sty) -> Format.fprintf ppf diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml index d26a6702a..b12e34032 100644 --- a/src/proto_alpha/lib_protocol/src/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -200,7 +200,7 @@ module Scripts = struct let ctxt = match maybe_gas with | None -> Gas.set_unlimited ctxt | Some gas -> Gas.set_limit ctxt gas in - Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ) -> + Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ) -> parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) -> Script_ir_translator.pack_data ctxt typ data >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt) diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml index 5d4582e90..b1d1f5d18 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml @@ -236,21 +236,27 @@ module Cost_of = struct end module Unparse = struct - let prim_cost = alloc_cost 4 (* location, primitive name, list, annotation *) + let prim_cost nb_args = + alloc_cost 4 (* location, primitive name, list, annotation *) +@ + (nb_args *@ alloc_cost 2) + let seq_cost nb_args = + alloc_cost 2 (* location, list *) +@ + (nb_args *@ alloc_cost 2) let string_cost length = alloc_cost 3 +@ alloc_bytes_cost length let cycle = step_cost 1 - let bool = prim_cost - let unit = prim_cost + let bool = prim_cost 0 + let unit = prim_cost 0 (* FIXME: not sure we should count the length of strings and bytes as they are shared *) let string s = string_cost (String.length s) let bytes s = alloc_bytes_cost (MBytes.length s) (* Approximates log10(x) *) - let int i = - let decimal_digits = (Z.numbits (Z.abs (Script_int.to_zint i))) / 4 in - prim_cost +@ (alloc_bytes_cost decimal_digits) + let z i = + let decimal_digits = (Z.numbits (Z.abs i)) / 4 in + prim_cost 0 +@ (alloc_bytes_cost decimal_digits) + let int i = z (Script_int.to_zint i) let tez = string_cost 19 (* max length of 64 bit int *) let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int let operation bytes = string_cost (MBytes.length bytes * 2) @@ -258,17 +264,15 @@ module Cost_of = struct let key_hash = string_cost 36 let signature = string_cost 128 let contract = string_cost 36 - let pair = prim_cost +@ alloc_cost 4 - let union = prim_cost +@ alloc_cost 2 - let lambda = prim_cost +@ alloc_cost 3 - let some = prim_cost +@ alloc_cost 2 - let none = prim_cost - let list_element = prim_cost +@ alloc_cost 2 + let pair = prim_cost 2 + let union = prim_cost 1 + let some = prim_cost 1 + let none = prim_cost 0 + let list_element = prim_cost 1 let set_element = alloc_cost 2 let map_element = alloc_cost 2 - let primitive_type = prim_cost - let one_arg_type = prim_cost +@ alloc_cost 2 - let two_arg_type = prim_cost +@ alloc_cost 4 + let one_arg_type = prim_cost 1 + let two_arg_type = prim_cost 2 let set_to_list = set_to_list let map_to_list = map_to_list diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli index 87498fa7e..bea418e2e 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli @@ -135,9 +135,12 @@ module Cost_of : sig end module Unparse : sig + val prim_cost : int -> Gas.cost + val seq_cost : int -> Gas.cost val cycle : Gas.cost val unit : Gas.cost val bool : Gas.cost + val z : Z.t -> Gas.cost val int : 'a Script_int.num -> Gas.cost val tez : Gas.cost val string : string -> Gas.cost @@ -155,8 +158,6 @@ module Cost_of : sig val union : Gas.cost - val lambda : Gas.cost - val some : Gas.cost val none : Gas.cost @@ -164,7 +165,6 @@ module Cost_of : sig val set_element : Gas.cost val map_element : Gas.cost - val primitive_type : Gas.cost val one_arg_type : Gas.cost val two_arg_type : Gas.cost val set_to_list : 'a Script_typed_ir.set -> Gas.cost diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index e772b03bc..6cbc6951f 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -21,6 +21,9 @@ type error += Reject of Script.location * Script.expr * execution_trace option type error += Overflow of Script.location * execution_trace option type error += Runtime_contract_error : Contract.t * Script.expr -> error type error += Bad_contract_parameter of Contract.t (* `Permanent *) +type error += Cannot_serialize_log +type error += Cannot_serialize_failure +type error += Cannot_serialize_storage let () = let open Data_encoding in @@ -82,7 +85,37 @@ let () = the wrong type" Data_encoding.(obj1 (req "contract" Contract.encoding)) (function Bad_contract_parameter c -> Some c | _ -> None) - (fun c -> Bad_contract_parameter c) + (fun c -> Bad_contract_parameter c) ; + (* Cannot serialize log *) + register_error_kind + `Temporary + ~id:"cannotSerializeLog" + ~title:"Not enough gas to serialize execution trace" + ~description:"Execution trace with stacks was to big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_log -> Some () | _ -> None) + (fun () -> Cannot_serialize_log) ; + (* Cannot serialize failure *) + register_error_kind + `Temporary + ~id:"cannotSerializeFailure" + ~title:"Not enough gas to serialize argument of FAILWITH" + ~description:"Argument of FAILWITH was too big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_failure -> Some () | _ -> None) + (fun () -> Cannot_serialize_failure) ; + (* Cannot serialize storage *) + register_error_kind + `Temporary + ~id:"cannotSerializeStorage" + ~title:"Not enough gas to serialize execution storage" + ~description:"The returned storage was too big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_storage -> Some () | _ -> None) + (fun () -> Cannot_serialize_storage) (* ---- interpreter ---------------------------------------------------------*) @@ -132,7 +165,9 @@ let rec interp match log with | None -> return (ret, ctxt) | Some log -> - unparse_stack ctxt (ret, descr.aft) >>=? fun stack -> + trace + Cannot_serialize_log + (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> log := (descr.loc, Gas.level ctxt, stack) :: !log ; return (ret, ctxt) in let get_log (log : execution_trace ref option) = @@ -544,7 +579,8 @@ let rec interp Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> logged_return (Item (lam, rest), ctxt) | Failwith tv, Item (v, _) -> - unparse_data ctxt Optimized tv v >>=? fun (v, _ctxt) -> + trace Cannot_serialize_failure + (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> let v = Micheline.strip_locations v in fail (Reject (loc, v, get_log log)) | Nop, stack -> @@ -658,10 +694,12 @@ let rec interp (credit, Item (init, rest)))))) -> Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (u_param_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (u_storage_type, ctxt) -> let code = Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparse_ty param_type ], []) ; - Prim (0, K_storage, [ unparse_ty storage_type ], []) ; + (Seq (0, [ Prim (0, K_parameter, [ u_param_type ], []) ; + Prim (0, K_storage, [ u_storage_type ], []) ; Prim (0, K_code, [ Micheline.root code ], []) ])) in unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> let storage = Micheline.strip_locations storage in @@ -732,7 +770,8 @@ let rec interp begin match log with | None -> return_unit | Some log -> - unparse_stack ctxt (stack, code.bef) >>=? fun stack -> + trace Cannot_serialize_log + (unparse_stack ctxt (stack, code.bef)) >>=? fun stack -> log := (code.loc, Gas.level ctxt, stack) :: !log ; return_unit end >>=? fun () -> @@ -755,7 +794,8 @@ and execute ?log ctxt mode ~source ~payer ~self script amount arg : (Runtime_contract_error (self, script_code)) (interp ?log ctxt ~source ~payer ~self amount code (arg, storage)) >>=? fun ((ops, sto), ctxt) -> - unparse_data ctxt mode storage_type sto >>=? fun (storage, ctxt) -> + trace Cannot_serialize_storage + (unparse_data ctxt mode storage_type sto) >>=? fun (storage, ctxt) -> return (Micheline.strip_locations storage, ops, ctxt, Script_ir_translator.extract_big_map storage_type sto) diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli index 9661f7cb6..48d7f638e 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli @@ -16,6 +16,9 @@ type error += Reject of Script.location * Script.expr * execution_trace option type error += Overflow of Script.location * execution_trace option type error += Runtime_contract_error : Contract.t * Script.expr -> error type error += Bad_contract_parameter of Contract.t (* `Permanent *) +type error += Cannot_serialize_log +type error += Cannot_serialize_failure +type error += Cannot_serialize_storage type execution_result = { ctxt : context ; 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 05fc02615..bfcb05d67 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -14,6 +14,9 @@ open Script_typed_ir open Script_tc_errors open Script_ir_annot +module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking +module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse + type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty type ex_ty = Ex_ty : 'a ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty @@ -590,6 +593,62 @@ let rec unparse_ty let tr = unparse_ty utr in Prim (-1, T_big_map, [ ta; tr ], unparse_type_annot tname) +let rec account_gas_node + : context tzresult -> Script.node -> context tzresult + = fun ctxt node -> + match ctxt with + | Error _ -> ctxt + | Ok ctxt -> + Gas.consume ctxt Unparse_costs.cycle >>? fun ctxt -> + match node with + | Int (_, v) -> + Gas.consume ctxt (Unparse_costs.z v) + | String (_, s) -> + Gas.consume ctxt (Unparse_costs.string s) + | Bytes (_, s) -> + Gas.consume ctxt (Unparse_costs.bytes s) + | Prim (_, _, args, _) -> + List.fold_left account_gas_node (ok ctxt) args >>? fun ctxt -> + Gas.consume ctxt (Unparse_costs.prim_cost (List.length args)) + | Seq (_, args) -> + List.fold_left account_gas_node (ok ctxt) args >>? fun ctxt -> + Gas.consume ctxt (Unparse_costs.seq_cost (List.length args)) + +(* unparse_ty with gas accounting *) +let unparse_ty_no_lwt + : type a. context -> a ty -> (Script.node * context) tzresult + = fun ctxt ty -> + let ty = unparse_ty ty in + account_gas_node (ok ctxt) ty >|? fun ctxt -> + (ty, ctxt) + +let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty) + +let rec strip_var_annots = function + | Int _ | String _ | Bytes _ as atom -> atom + | Seq (loc, args) -> Seq (loc, List.map strip_var_annots args) + | Prim (loc, name, args, annots) -> + let not_var_annot s = Compare.Char.(String.get s 0 <> '@') in + let annots = List.filter not_var_annot annots in + Prim (loc, name, List.map strip_var_annots args, annots) + +let serialize_ty_for_error ctxt ty = + unparse_ty_no_lwt ctxt ty |> + record_trace Cannot_serialize_error >|? fun (ty, ctxt) -> + strip_locations (strip_var_annots ty), ctxt + +let rec unparse_stack + : type a. context -> a stack_ty -> ((Script.expr * Script.annot) list * context) tzresult Lwt.t + = fun ctxt -> function + | Empty_t -> return ([], ctxt) + | Item_t (ty, rest, annot) -> + unparse_ty ctxt ty >>=? fun (uty, ctxt) -> + unparse_stack ctxt rest >>=? fun (urest, ctxt) -> + return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt) + +let serialize_stack_for_error ctxt stack_ty = + trace Cannot_serialize_error (unparse_stack ctxt stack_ty) + let name_of_ty : type a. a ty -> type_annot option = function @@ -622,9 +681,10 @@ type ('ta, 'tb) eq = Eq : ('same, 'same) eq let comparable_ty_eq : type ta tb. + context -> ta comparable_ty -> tb comparable_ty -> (ta comparable_ty, tb comparable_ty) eq tzresult - = fun ta tb -> match ta, tb with + = fun ctxt ta tb -> match ta, tb with | Int_key _, Int_key _ -> Ok Eq | Nat_key _, Nat_key _ -> Ok Eq | String_key _, String_key _ -> Ok Eq @@ -633,11 +693,42 @@ let comparable_ty_eq | Key_hash_key _, Key_hash_key _ -> Ok Eq | Timestamp_key _, Timestamp_key _ -> Ok Eq | Address_key _, Address_key _ -> Ok Eq - | _, _ -> error (Inconsistent_types (ty_of_comparable_ty ta, ty_of_comparable_ty tb)) + | _, _ -> + serialize_ty_for_error ctxt (ty_of_comparable_ty ta) >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt (ty_of_comparable_ty tb) >>? fun (tb, _ctxt) -> + error (Inconsistent_types (ta, tb)) + + +let record_trace mk_err result = + match result with + | Ok _ as res -> res + | Error errs -> + mk_err () >>? fun err -> + Error (err :: errs) + +let trace mk_err f = + f >>= function + | Error errs -> + mk_err () >>=? fun err -> + Lwt.return (Error (err :: errs)) + | ok -> Lwt.return ok + + +let record_inconsistent ctxt ta tb = + record_trace (fun () -> + serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> + Inconsistent_types (ta, tb)) + +let record_inconsistent_type_annotations ctxt loc ta tb = + record_trace (fun () -> + serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb >|? fun (tb, _ctxt) -> + Inconsistent_type_annotations (loc, ta, tb)) let rec ty_eq - : type ta tb. ta ty -> tb ty -> (ta ty, tb ty) eq tzresult - = fun ta tb -> + : type ta tb. context -> ta ty -> tb ty -> (ta ty, tb ty) eq tzresult + = fun ctxt ta tb -> match ta, tb with | Unit_t _, Unit_t _ -> Ok Eq | Int_t _, Int_t _ -> Ok Eq @@ -653,57 +744,60 @@ let rec ty_eq | Bool_t _, Bool_t _ -> Ok Eq | Operation_t _, Operation_t _ -> Ok Eq | Map_t (tal, tar, _), Map_t (tbl, tbr, _) -> - (comparable_ty_eq tal tbl >>? fun Eq -> - ty_eq tar tbr >>? fun Eq -> + (comparable_ty_eq ctxt tal tbl >>? fun Eq -> + ty_eq ctxt tar tbr >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _) -> - (comparable_ty_eq tal tbl >>? fun Eq -> - ty_eq tar tbr >>? fun Eq -> + (comparable_ty_eq ctxt tal tbl >>? fun Eq -> + ty_eq ctxt tar tbr >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | Set_t (ea, _), Set_t (eb, _) -> - (comparable_ty_eq ea eb >>? fun Eq -> + (comparable_ty_eq ctxt ea eb >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | Pair_t ((tal, _, _), (tar, _, _), _), Pair_t ((tbl, _, _), (tbr, _, _), _) -> - (ty_eq tal tbl >>? fun Eq -> - ty_eq tar tbr >>? fun Eq -> + (ty_eq ctxt tal tbl >>? fun Eq -> + ty_eq ctxt tar tbr >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | Union_t ((tal, _), (tar, _), _), Union_t ((tbl, _), (tbr, _), _) -> - (ty_eq tal tbl >>? fun Eq -> - ty_eq tar tbr >>? fun Eq -> + (ty_eq ctxt tal tbl >>? fun Eq -> + ty_eq ctxt tar tbr >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _) -> - (ty_eq tal tbl >>? fun Eq -> - ty_eq tar tbr >>? fun Eq -> + (ty_eq ctxt tal tbl >>? fun Eq -> + ty_eq ctxt tar tbr >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | Contract_t (tal, _), Contract_t (tbl, _) -> - (ty_eq tal tbl >>? fun Eq -> + (ty_eq ctxt tal tbl >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | Option_t ((tva, _), _, _), Option_t ((tvb, _), _, _) -> - (ty_eq tva tvb >>? fun Eq -> + (ty_eq ctxt tva tvb >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb | List_t (tva, _), List_t (tvb, _) -> - (ty_eq tva tvb >>? fun Eq -> + (ty_eq ctxt tva tvb >>? fun Eq -> (Ok Eq : (ta ty, tb ty) eq tzresult)) |> - record_trace (Inconsistent_types (ta, tb)) - | _, _ -> error (Inconsistent_types (ta, tb)) + record_inconsistent ctxt ta tb + | _, _ -> + serialize_ty_for_error ctxt ta >>? fun (ta, ctxt) -> + serialize_ty_for_error ctxt tb >>? fun (tb, _ctxt) -> + error (Inconsistent_types (ta, tb)) let rec stack_ty_eq - : type ta tb. int -> ta stack_ty -> tb stack_ty -> - (ta stack_ty, tb stack_ty) eq tzresult = fun lvl ta tb -> + : type ta tb. context -> int -> ta stack_ty -> tb stack_ty -> + (ta stack_ty, tb stack_ty) eq tzresult = fun ctxt lvl ta tb -> match ta, tb with | Item_t (tva, ra, _), Item_t (tvb, rb, _) -> - ty_eq tva tvb |> - record_trace (Bad_stack_item lvl) >>? fun Eq -> - stack_ty_eq (lvl + 1) ra rb >>? fun Eq -> + ty_eq ctxt tva tvb |> + record_trace (fun () -> ok (Bad_stack_item lvl)) >>? fun Eq -> + stack_ty_eq ctxt (lvl + 1) ra rb >>? fun Eq -> (Ok Eq : (ta stack_ty, tb stack_ty) eq tzresult) | Empty_t, Empty_t -> Ok Eq | _, _ -> error Bad_stack_length @@ -746,112 +840,112 @@ let rec strip_annotations = function | Seq (loc, items) -> Seq (loc, List.map strip_annotations items) let merge_types : - type b.Script.location -> b ty -> b ty -> b ty tzresult = - let rec help : type a.a ty -> a ty -> a ty tzresult - = fun ty1 ty2 -> - match ty1, ty2 with - | Unit_t tn1, Unit_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Unit_t tname - | Int_t tn1, Int_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Int_t tname - | Nat_t tn1, Nat_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Nat_t tname - | Key_t tn1, Key_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Key_t tname - | Key_hash_t tn1, Key_hash_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Key_hash_t tname - | String_t tn1, String_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - String_t tname - | Bytes_t tn1, Bytes_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Bytes_t tname - | Signature_t tn1, Signature_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Signature_t tname - | Mutez_t tn1, Mutez_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Mutez_t tname - | Timestamp_t tn1, Timestamp_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Timestamp_t tname - | Address_t tn1, Address_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Address_t tname - | Bool_t tn1, Bool_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Bool_t tname - | Operation_t tn1, Operation_t tn2 -> - merge_type_annot tn1 tn2 >|? fun tname -> - Operation_t tname - | Map_t (tal, tar, tn1), Map_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - help tar tbr >>? fun value -> - ty_eq tar value >>? fun Eq -> - merge_comparable_types tal tbl >|? fun tk -> - Map_t (tk, value, tname) - | Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - help tar tbr >>? fun value -> - ty_eq tar value >>? fun Eq -> - merge_comparable_types tal tbl >|? fun tk -> - Big_map_t (tk, value, tname) - | Set_t (ea, tn1), Set_t (eb, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_comparable_types ea eb >|? fun e -> - Set_t (e, tname) - | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1), - Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot l_field1 l_field2 >>? fun l_field -> - merge_field_annot r_field1 r_field2 >>? fun r_field -> - let l_var = merge_var_annot l_var1 l_var2 in - let r_var = merge_var_annot r_var1 r_var2 in - help tal tbl >>? fun left_ty -> - help tar tbr >|? fun right_ty -> - Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname) - | Union_t ((tal, tal_annot), (tar, tar_annot), tn1), - Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot tal_annot tbl_annot >>? fun left_annot -> - merge_field_annot tar_annot tbr_annot >>? fun right_annot -> - help tal tbl >>? fun left_ty -> - help tar tbr >|? fun right_ty -> - Union_t ((left_ty, left_annot), (right_ty, right_annot), tname) - | Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - help tal tbl >>? fun left_ty -> - help tar tbr >|? fun right_ty -> - Lambda_t (left_ty, right_ty, tname) - | Contract_t (tal, tn1), Contract_t (tbl, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - help tal tbl >|? fun arg_ty -> - Contract_t (arg_ty, tname) - | Option_t ((tva, some_annot_a), none_annot_a, tn1), - Option_t ((tvb, some_annot_b), none_annot_b, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - merge_field_annot some_annot_a some_annot_b >>? fun some_annot -> - merge_field_annot none_annot_a none_annot_b >>? fun none_annot -> - help tva tvb >|? fun ty -> - Option_t ((ty, some_annot), none_annot, tname) - | List_t (tva, tn1), List_t (tvb, tn2) -> - merge_type_annot tn1 tn2 >>? fun tname -> - help tva tvb >|? fun ty -> - List_t (ty, tname) - | _, _ -> assert false - in (fun loc ty1 ty2 -> - record_trace - (Inconsistent_type_annotations (loc, ty1, ty2)) - (help ty1 ty2)) + type b. context -> Script.location -> b ty -> b ty -> b ty tzresult = + fun ctxt -> + let rec help : type a. a ty -> a ty -> a ty tzresult + = fun ty1 ty2 -> + match ty1, ty2 with + | Unit_t tn1, Unit_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Unit_t tname + | Int_t tn1, Int_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Int_t tname + | Nat_t tn1, Nat_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Nat_t tname + | Key_t tn1, Key_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Key_t tname + | Key_hash_t tn1, Key_hash_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Key_hash_t tname + | String_t tn1, String_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + String_t tname + | Bytes_t tn1, Bytes_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Bytes_t tname + | Signature_t tn1, Signature_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Signature_t tname + | Mutez_t tn1, Mutez_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Mutez_t tname + | Timestamp_t tn1, Timestamp_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Timestamp_t tname + | Address_t tn1, Address_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Address_t tname + | Bool_t tn1, Bool_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Bool_t tname + | Operation_t tn1, Operation_t tn2 -> + merge_type_annot tn1 tn2 >|? fun tname -> + Operation_t tname + | Map_t (tal, tar, tn1), Map_t (tbl, tbr, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help tar tbr >>? fun value -> + ty_eq ctxt tar value >>? fun Eq -> + merge_comparable_types tal tbl >|? fun tk -> + Map_t (tk, value, tname) + | Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help tar tbr >>? fun value -> + ty_eq ctxt tar value >>? fun Eq -> + merge_comparable_types tal tbl >|? fun tk -> + Big_map_t (tk, value, tname) + | Set_t (ea, tn1), Set_t (eb, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_comparable_types ea eb >|? fun e -> + Set_t (e, tname) + | Pair_t ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1), + Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_field_annot l_field1 l_field2 >>? fun l_field -> + merge_field_annot r_field1 r_field2 >>? fun r_field -> + let l_var = merge_var_annot l_var1 l_var2 in + let r_var = merge_var_annot r_var1 r_var2 in + help tal tbl >>? fun left_ty -> + help tar tbr >|? fun right_ty -> + Pair_t ((left_ty, l_field, l_var), (right_ty, r_field, r_var), tname) + | Union_t ((tal, tal_annot), (tar, tar_annot), tn1), + Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_field_annot tal_annot tbl_annot >>? fun left_annot -> + merge_field_annot tar_annot tbr_annot >>? fun right_annot -> + help tal tbl >>? fun left_ty -> + help tar tbr >|? fun right_ty -> + Union_t ((left_ty, left_annot), (right_ty, right_annot), tname) + | Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help tal tbl >>? fun left_ty -> + help tar tbr >|? fun right_ty -> + Lambda_t (left_ty, right_ty, tname) + | Contract_t (tal, tn1), Contract_t (tbl, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help tal tbl >|? fun arg_ty -> + Contract_t (arg_ty, tname) + | Option_t ((tva, some_annot_a), none_annot_a, tn1), + Option_t ((tvb, some_annot_b), none_annot_b, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + merge_field_annot some_annot_a some_annot_b >>? fun some_annot -> + merge_field_annot none_annot_a none_annot_b >>? fun none_annot -> + help tva tvb >|? fun ty -> + Option_t ((ty, some_annot), none_annot, tname) + | List_t (tva, tn1), List_t (tvb, tn2) -> + merge_type_annot tn1 tn2 >>? fun tname -> + help tva tvb >|? fun ty -> + List_t (ty, tname) + | _, _ -> assert false + in (fun loc ty1 ty2 -> + record_inconsistent_type_annotations ctxt loc ty1 ty2 + (help ty1 ty2)) let merge_stacks - : type ta. Script.location -> ta stack_ty -> ta stack_ty -> ta stack_ty tzresult - = fun loc -> + : type ta. context -> Script.location -> ta stack_ty -> ta stack_ty -> ta stack_ty tzresult + = fun ctxt loc -> let rec help : type a. a stack_ty -> a stack_ty -> a stack_ty tzresult = fun stack1 stack2 -> match stack1, stack2 with @@ -859,7 +953,7 @@ let merge_stacks | Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2) -> let annot = merge_var_annot annot1 annot2 in - merge_types loc ty1 ty2 >>? fun ty -> + merge_types ctxt loc ty1 ty2 >>? fun ty -> help rest1 rest2 >|? fun rest -> Item_t (ty, rest, annot) in help @@ -877,17 +971,19 @@ type ('t, 'f, 'b) branch = let merge_branches - : type bef a b. int -> a judgement -> b judgement -> + : type bef a b. context -> int -> a judgement -> b judgement -> (a, b, bef) branch -> bef judgement tzresult Lwt.t - = fun loc btr bfr { branch } -> + = fun ctxt loc btr bfr { branch } -> match btr, bfr with | Typed ({ aft = aftbt ; _ } as dbt), Typed ({ aft = aftbf ; _ } as dbf) -> - let unmatched_branches = (Unmatched_branches (loc, aftbt, aftbf)) in - trace - unmatched_branches - (Lwt.return (stack_ty_eq 1 aftbt aftbf) >>=? fun Eq -> - Lwt.return (merge_stacks loc aftbt aftbf) >>=? fun merged_stack -> + let unmatched_branches () = + serialize_stack_for_error ctxt aftbt >>=? fun (aftbt, ctxt) -> + serialize_stack_for_error ctxt aftbf >>|? fun (aftbf, _ctxt) -> + Unmatched_branches (loc, aftbt, aftbf) in + trace unmatched_branches + (Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf) >>=? fun Eq -> + Lwt.return (merge_stacks ctxt loc aftbt aftbf) >>=? fun merged_stack -> return (Typed (branch {dbt with aft=merged_stack} {dbf with aft=merged_stack}))) | Failed { descr = descrt }, Failed { descr = descrf } -> let descr ret = @@ -898,11 +994,9 @@ let merge_branches | Failed { descr = descrt }, Typed dbf -> return (Typed (branch (descrt dbf.aft) dbf)) -module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking - let rec parse_comparable_ty - : Script.node -> ex_comparable_ty tzresult - = function + : context -> Script.node -> ex_comparable_ty tzresult + = fun ctxt -> function | Prim (loc, T_int, [], annot) -> parse_type_annot loc annot >|? fun tname -> Ex_comparable_ty ( Int_key tname ) @@ -934,7 +1028,8 @@ let rec parse_comparable_ty | 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 ~allow_big_map:false ~allow_operation:false expr >>? fun (Ex_ty ty) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation:false expr >>? fun (Ex_ty ty) -> + serialize_ty_for_error ctxt ty >>? fun (ty, _ctxt) -> error (Comparable_type_expected (loc, ty)) | expr -> error @@ unexpected expr [] Type_namespace @@ -943,10 +1038,11 @@ let rec parse_comparable_ty T_key ; T_key_hash ; T_timestamp ] and parse_ty : + context -> allow_big_map: bool -> allow_operation: bool -> Script.node -> ex_ty tzresult - = fun ~allow_big_map ~allow_operation node -> + = fun ctxt ~allow_big_map ~allow_operation node -> match node with | Prim (loc, T_pair, [ Prim (big_map_loc, T_big_map, args, map_annot) ; remaining_storage ], @@ -954,10 +1050,10 @@ and parse_ty : when allow_big_map -> begin match args with | [ key_ty ; value_ty ] -> - parse_comparable_ty key_ty >>? fun (Ex_comparable_ty key_ty) -> - parse_ty ~allow_big_map:false ~allow_operation value_ty + parse_comparable_ty ctxt key_ty >>? fun (Ex_comparable_ty key_ty) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation value_ty >>? fun (Ex_ty value_ty) -> - parse_ty ~allow_big_map:false ~allow_operation remaining_storage + parse_ty ctxt ~allow_big_map:false ~allow_operation remaining_storage >>? fun (Ex_ty remaining_storage) -> parse_type_annot big_map_loc map_annot >>? fun map_name -> parse_composed_type_annot loc storage_annot @@ -1011,44 +1107,44 @@ and parse_ty : else error (Unexpected_operation loc) | Prim (loc, T_contract, [ utl ], annot) -> - parse_ty ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl) -> parse_type_annot loc annot >|? fun ty_name -> Ex_ty (Contract_t (tl, ty_name)) | Prim (loc, T_pair, [ utl; utr ], annot) -> extract_field_annot utl >>? fun (utl, left_field) -> extract_field_annot utr >>? fun (utr, right_field) -> - parse_ty ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl) -> - parse_ty ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> parse_type_annot loc annot >|? fun ty_name -> Ex_ty (Pair_t ((tl, left_field, None), (tr, right_field, None), ty_name)) | Prim (loc, T_or, [ utl; utr ], annot) -> extract_field_annot utl >>? fun (utl, left_constr) -> extract_field_annot utr >>? fun (utr, right_constr) -> - parse_ty ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl) -> - parse_ty ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation utl >>? fun (Ex_ty tl) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> parse_type_annot loc annot >|? fun ty_name -> Ex_ty (Union_t ((tl, left_constr), (tr, right_constr), ty_name)) | Prim (loc, T_lambda, [ uta; utr ], annot) -> - parse_ty ~allow_big_map:false ~allow_operation uta >>? fun (Ex_ty ta) -> - parse_ty ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation uta >>? fun (Ex_ty ta) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> parse_type_annot loc annot >|? fun ty_name -> Ex_ty (Lambda_t (ta, tr, ty_name)) | Prim (loc, T_option, [ ut ], annot) -> extract_field_annot ut >>? fun (ut, some_constr) -> - parse_ty ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t) -> parse_composed_type_annot loc annot >|? fun (ty_name, none_constr, _) -> Ex_ty (Option_t ((t, some_constr), none_constr, ty_name)) | Prim (loc, T_list, [ ut ], annot) -> - parse_ty ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation ut >>? fun (Ex_ty t) -> parse_type_annot loc annot >|? fun ty_name -> Ex_ty (List_t (t, ty_name)) | Prim (loc, T_set, [ ut ], annot) -> - parse_comparable_ty ut >>? fun (Ex_comparable_ty t) -> + parse_comparable_ty ctxt ut >>? fun (Ex_comparable_ty t) -> parse_type_annot loc annot >|? fun ty_name -> Ex_ty (Set_t (t, ty_name)) | Prim (loc, T_map, [ uta; utr ], annot) -> - parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) -> - parse_ty ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> + parse_comparable_ty ctxt uta >>? fun (Ex_comparable_ty ta) -> + parse_ty ctxt ~allow_big_map:false ~allow_operation utr >>? fun (Ex_ty tr) -> parse_type_annot loc annot >|? fun ty_name -> Ex_ty (Map_t (ta, tr, ty_name)) | Prim (loc, T_big_map, _, _) -> @@ -1101,13 +1197,6 @@ let check_no_big_map_or_operation loc root = | Contract_t (_, _) -> ok () in check root -let rec unparse_stack - : type a. a stack_ty -> (Script.expr * Script.annot) list - = function - | Empty_t -> [] - | Item_t (ty, rest, annot) -> - (strip_locations (unparse_ty ty), unparse_var_annot annot) :: unparse_stack rest - type ex_script = Ex_script : ('a, 'c) script -> ex_script (* Lwt versions *) @@ -1129,9 +1218,10 @@ let rec parse_data = fun ?type_logger ctxt ty script_data -> Lwt.return (Gas.consume ctxt Typecheck_costs.cycle) >>=? fun ctxt -> let error () = + Lwt.return (serialize_ty_for_error ctxt ty) >>|? fun (ty, _ctxt) -> Invalid_constant (location script_data, strip_locations script_data, ty) in let traced body = - trace (error ()) body in + trace error body in let parse_items ?type_logger loc ctxt expr key_type value_type items item_wrapper = fold_left_s (fun (last_value, map, ctxt) item -> @@ -1156,7 +1246,7 @@ let rec parse_data | Prim (loc, name, _, _) -> fail @@ Invalid_primitive (loc, [ D_Elt ], name) | Int _ | String _ | Bytes _ | Seq _ -> - fail (error ())) + error () >>=? fail) (None, empty_map key_type, ctxt) items |> traced >>|? fun (_, items, ctxt) -> (items, ctxt) in match ty, script_data with @@ -1193,7 +1283,7 @@ let rec parse_data if check_printable_ascii (String.length v - 1) then return (v, ctxt) else - fail (error ()) + error () >>=? fail | String_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Byte sequences *) @@ -1209,7 +1299,8 @@ let rec parse_data let v = Script_int.of_zint v in if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then return (Script_int.abs v, ctxt) - else fail (error ()) + else + error () >>=? fail | Int_t _, expr -> traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) | Nat_t _, expr -> @@ -1222,7 +1313,7 @@ let rec parse_data | None -> raise Exit | Some tez -> return (tez, ctxt) with _ -> - fail @@ error () + error () >>=? fail end | Mutez_t _, expr -> traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) @@ -1233,7 +1324,7 @@ let rec parse_data Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp) >>=? fun ctxt -> begin match Script_timestamp.of_string s with | Some v -> return (v, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Timestamp_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr))) @@ -1242,13 +1333,13 @@ let rec parse_data Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> begin match Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes with | Some k -> return (k, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Key_t _, String (_, s) -> (* As unparsed with [Readable]. *) Lwt.return (Gas.consume ctxt Typecheck_costs.key) >>=? fun ctxt -> begin match Signature.Public_key.of_b58check_opt s with | Some k -> return (k, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Key_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) @@ -1257,13 +1348,13 @@ let rec parse_data begin match Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes with | Some k -> return (k, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Key_hash_t _, String (_, s) (* As unparsed with [Readable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash) >>=? fun ctxt -> begin match Signature.Public_key_hash.of_b58check_opt s with | Some k -> return (k, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Key_hash_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) @@ -1272,13 +1363,13 @@ let rec parse_data Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> begin match Data_encoding.Binary.of_bytes Signature.encoding bytes with | Some k -> return (k, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Signature_t _, String (_, s) (* As unparsed with [Readable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.signature) >>=? fun ctxt -> begin match Signature.of_b58check_opt s with | Some s -> return (s, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Signature_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Bytes_kind ], kind expr))) @@ -1287,7 +1378,7 @@ let rec parse_data Lwt.return (Gas.consume ctxt (Typecheck_costs.operation bytes)) >>=? fun ctxt -> begin match Data_encoding.Binary.of_bytes Operation.internal_operation_encoding bytes with | Some op -> return (op, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Operation_t _, expr -> traced (fail (Invalid_kind (location expr, [ Bytes_kind ], kind expr))) @@ -1297,7 +1388,7 @@ let rec parse_data begin match Data_encoding.Binary.of_bytes Contract.encoding bytes with | Some c -> return (c, ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Address_t _, String (_, s) (* As unparsed with [Readable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> @@ -1313,7 +1404,7 @@ let rec parse_data | Some c -> traced (parse_contract ctxt loc ty c) >>=? fun (ctxt, _) -> return ((ty, c), ctxt) - | None -> fail (error ()) + | None -> error () >>=? fail end | Contract_t (ty, _), String (loc, s) (* As unparsed with [Readable]. *) -> Lwt.return (Gas.consume ctxt Typecheck_costs.contract) >>=? fun ctxt -> @@ -1441,11 +1532,16 @@ and parse_returning script_instr (Item_t (arg, Empty_t, arg_annot)) >>=? function | (Typed ({ loc ; aft = (Item_t (ty, Empty_t, _) as stack_ty) ; _ } as descr), gas) -> trace - (Bad_return (loc, stack_ty, ret)) - (Lwt.return (ty_eq ty ret) >>=? fun Eq -> - Lwt.return (merge_types loc ty ret) >>=? fun _ret -> + (fun () -> + Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_return (loc, stack_ty, ret)) + (Lwt.return (ty_eq ctxt ty ret) >>=? fun Eq -> + Lwt.return (merge_types ctxt loc ty ret) >>=? fun _ret -> return ((Lam (descr, strip_locations script_instr) : (arg, ret) lambda), gas)) | (Typed { loc ; aft = stack_ty ; _ }, _gas) -> + Lwt.return (serialize_ty_for_error ctxt ret) >>=? fun (ret, ctxt) -> + serialize_stack_for_error ctxt stack_ty >>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret)) | (Failed { descr }, gas) -> return ((Lam (descr (Item_t (ret, Empty_t, None)), strip_locations script_instr) @@ -1457,6 +1553,24 @@ and parse_instr tc_context -> context -> Script.node -> bef stack_ty -> (bef judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt script_instr stack_ty -> + let check_item check loc name n m = + trace (fun () -> + serialize_stack_for_error ctxt stack_ty >>|? fun (stack_ty, _ctxt) -> + Bad_stack (loc, name, m, stack_ty)) @@ + trace (fun () -> return (Bad_stack_item n)) @@ + Lwt.return check in + let check_item_ty exp got loc n = + check_item (ty_eq ctxt exp got) loc n in + let log_stack ctxt loc stack_ty aft : context tzresult Lwt.t = + match type_logger, script_instr with + | None, _ + | Some _, (Seq (-1, _) | Int _ | String _ | Bytes _) -> return ctxt + | Some log, (Prim _ | Seq _) -> + unparse_stack ctxt stack_ty >>=? fun (stack_ty, ctxt) -> + unparse_stack ctxt aft >>=? fun (aft, ctxt) -> + log loc stack_ty aft; + return ctxt + in let return : context -> bef judgement -> (bef judgement * context) tzresult Lwt.t = fun ctxt judgement -> match judgement with @@ -1471,21 +1585,8 @@ and parse_instr return (judgement, ctxt) | Failed _ -> return (judgement, ctxt) in - let check_item check loc name n m = - trace (Bad_stack (loc, name, m, stack_ty)) @@ - trace (Bad_stack_item n) @@ - Lwt.return check in - let check_item_ty exp got loc n = - check_item (ty_eq exp got) loc n in - let log_stack loc stack_ty aft = - match type_logger, script_instr with - | None, _ - | Some _, (Seq (-1, _) | Int _ | String _ | Bytes _) -> () - | Some log, (Prim _ | Seq _) -> - log loc (unparse_stack stack_ty) (unparse_stack aft) - in let typed ctxt loc instr aft = - log_stack loc stack_ty aft ; + log_stack ctxt loc stack_ty aft >>=? fun ctxt -> return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in match script_instr, stack_ty with (* stack ops *) @@ -1507,7 +1608,7 @@ and parse_instr | Prim (loc, I_PUSH, [ t ; d ], annot), stack -> parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:false t >>=? fun (Ex_ty t) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation: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, annot)) | Prim (loc, I_UNIT, [], annot), @@ -1524,7 +1625,7 @@ and parse_instr (Item_t (Option_t ((t, some_field), none_field, ty_name), rest, annot)) | Prim (loc, I_NONE, [ t ], annot), stack -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true t >>=? fun (Ex_ty t) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:true t >>=? fun (Ex_ty t) -> parse_constr_annot loc annot >>=? fun (annot, ty_name, some_field, none_field) -> typed ctxt loc (Cons_none t) (Item_t (Option_t ((t, some_field), none_field, ty_name), stack, annot)) @@ -1538,7 +1639,7 @@ and parse_instr parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>=? fun judgement -> + merge_branches ctxt loc btr bfr { branch } >>=? fun judgement -> return ctxt judgement (* pairs *) | Prim (loc, I_PAIR, [], annot), @@ -1572,14 +1673,14 @@ and parse_instr (* unions *) | Prim (loc, I_LEFT, [ tr ], annot), Item_t (tl, rest, stack_annot) -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true tr >>=? fun (Ex_ty tr) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:true tr >>=? fun (Ex_ty tr) -> parse_constr_annot loc annot ~if_special_first:(var_to_field_annot stack_annot) >>=? fun (annot, tname, l_field, r_field) -> typed ctxt loc Left (Item_t (Union_t ((tl, l_field), (tr, r_field), tname), rest, annot)) | Prim (loc, I_RIGHT, [ tl ], annot), Item_t (tr, rest, stack_annot) -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true tl >>=? fun (Ex_ty tl) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:true tl >>=? fun (Ex_ty tl) -> parse_constr_annot loc annot ~if_special_second:(var_to_field_annot stack_annot) >>=? fun (annot, tname, l_field, r_field) -> @@ -1595,12 +1696,12 @@ and parse_instr parse_instr ?type_logger tc_context ctxt bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>=? fun judgement -> + merge_branches ctxt loc btr bfr { branch } >>=? fun judgement -> return ctxt judgement (* lists *) | Prim (loc, I_NIL, [ t ], annot), stack -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true t >>=? fun (Ex_ty t) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:true t >>=? fun (Ex_ty t) -> parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> typed ctxt loc Nil (Item_t (List_t (t, ty_name), stack, annot)) | Prim (loc, I_CONS, [], annot), @@ -1622,7 +1723,7 @@ and parse_instr rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>=? fun judgement -> + merge_branches ctxt loc btr bfr { branch } >>=? fun judgement -> return ctxt judgement | Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _) -> @@ -1638,13 +1739,17 @@ and parse_instr body (Item_t (elt, starting_rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> - let invalid_map_body = Invalid_map_body (loc, ibody.aft) in + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> + Invalid_map_body (loc, aft) in trace invalid_map_body - (Lwt.return @@ stack_ty_eq 1 rest starting_rest >>=? fun Eq -> - Lwt.return @@ merge_stacks loc rest starting_rest >>=? fun rest -> + (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun Eq -> + Lwt.return @@ merge_stacks ctxt loc rest starting_rest >>=? fun rest -> typed ctxt loc (List_map ibody) (Item_t (List_t (ret, list_ty_name), rest, ret_annot))) - | Typed { aft ; _ } -> fail (Invalid_map_body (loc, aft)) + | Typed { aft ; _ } -> + serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> + fail (Invalid_map_body (loc, aft)) | Failed _ -> fail (Invalid_map_block_fail loc) end | Prim (loc, I_ITER, [ body ], annot), @@ -1656,10 +1761,13 @@ and parse_instr body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> - let invalid_iter_body = Invalid_iter_body (loc, rest, ibody.aft) in + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> + Invalid_iter_body (loc, rest, aft) in trace invalid_iter_body - (Lwt.return @@ stack_ty_eq 1 aft rest >>=? fun Eq -> - Lwt.return @@ merge_stacks loc aft rest >>=? fun rest -> + (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun Eq -> + Lwt.return @@ merge_stacks ctxt loc aft rest >>=? fun rest -> typed ctxt loc (List_iter ibody) rest) | Failed { descr } -> typed ctxt loc (List_iter (descr rest)) rest @@ -1667,7 +1775,7 @@ and parse_instr (* sets *) | Prim (loc, I_EMPTY_SET, [ t ], annot), rest -> - Lwt.return @@ parse_comparable_ty t >>=? fun (Ex_comparable_ty t) -> + Lwt.return @@ parse_comparable_ty ctxt t >>=? fun (Ex_comparable_ty t) -> parse_var_type_annot loc annot >>=? fun (annot, tname) -> typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot)) | Prim (loc, I_ITER, [ body ], annot), @@ -1680,10 +1788,13 @@ and parse_instr body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> - let invalid_iter_body = Invalid_iter_body (loc, rest, ibody.aft) in + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> + Invalid_iter_body (loc, rest, aft) in trace invalid_iter_body - (Lwt.return @@ stack_ty_eq 1 aft rest >>=? fun Eq -> - Lwt.return @@ merge_stacks loc aft rest >>=? fun rest -> + (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun Eq -> + Lwt.return @@ merge_stacks ctxt loc aft rest >>=? fun rest -> typed ctxt loc (Set_iter ibody) rest) | Failed { descr } -> typed ctxt loc (Set_iter (descr rest)) rest @@ -1707,8 +1818,8 @@ and parse_instr (* maps *) | Prim (loc, I_EMPTY_MAP, [ tk ; tv ], annot), stack -> - Lwt.return @@ parse_comparable_ty tk >>=? fun (Ex_comparable_ty tk) -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true tv >>=? fun (Ex_ty tv) -> + Lwt.return @@ parse_comparable_ty ctxt tk >>=? fun (Ex_comparable_ty tk) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:true tv >>=? fun (Ex_ty tv) -> parse_var_type_annot loc annot >>=? fun (annot, ty_name) -> typed ctxt loc (Empty_map (tk, tv)) (Item_t (Map_t (tk, tv, ty_name), stack, annot)) | Prim (loc, I_MAP, [ body ], annot), @@ -1723,13 +1834,17 @@ and parse_instr starting_rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> - let invalid_map_body = Invalid_map_body (loc, ibody.aft) in + let invalid_map_body () = + serialize_stack_for_error ctxt ibody.aft >>|? fun (aft, _ctxt) -> + Invalid_map_body (loc, aft) in trace invalid_map_body - (Lwt.return @@ stack_ty_eq 1 rest starting_rest >>=? fun Eq -> - Lwt.return @@ merge_stacks loc rest starting_rest >>=? fun rest -> + (Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest >>=? fun Eq -> + Lwt.return @@ merge_stacks ctxt loc rest starting_rest >>=? fun rest -> typed ctxt loc (Map_map ibody) (Item_t (Map_t (ck, ret, ty_name), rest, ret_annot))) - | Typed { aft ; _ } -> fail (Invalid_map_body (loc, aft)) + | Typed { aft ; _ } -> + serialize_stack_for_error ctxt aft >>=? fun (aft, _ctxt) -> + fail (Invalid_map_body (loc, aft)) | Failed _ -> fail (Invalid_map_block_fail loc) end | Prim (loc, I_ITER, [ body ], annot), @@ -1744,10 +1859,13 @@ and parse_instr rest, None)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> - let invalid_iter_body = Invalid_iter_body (loc, rest, ibody.aft) in + let invalid_iter_body () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt rest >>|? fun (rest, _ctxt) -> + Invalid_iter_body (loc, rest, aft) in trace invalid_iter_body - (Lwt.return @@ stack_ty_eq 1 aft rest >>=? fun Eq -> - Lwt.return @@ merge_stacks loc aft rest >>=? fun rest -> + (Lwt.return @@ stack_ty_eq ctxt 1 aft rest >>=? fun Eq -> + Lwt.return @@ merge_stacks ctxt loc aft rest >>=? fun rest -> typed ctxt loc (Map_iter ibody) rest) | Failed { descr } -> typed ctxt loc (Map_iter (descr rest)) rest @@ -1845,7 +1963,7 @@ and parse_instr parse_instr ?type_logger tc_context ctxt bf rest >>=? fun (bfr, ctxt) -> let branch ibt ibf = { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in - merge_branches loc btr bfr { branch } >>=? fun judgement -> + merge_branches ctxt loc btr bfr { branch } >>=? fun judgement -> return ctxt judgement | Prim (loc, I_LOOP, [ body ], annot), (Item_t (Bool_t _, rest, _stack_annot) as stack) -> @@ -1855,10 +1973,13 @@ and parse_instr rest >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> - let unmatched_branches = Unmatched_branches (loc, ibody.aft, stack) in + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> + Unmatched_branches (loc, aft, stack) in trace unmatched_branches - (Lwt.return @@ stack_ty_eq 1 ibody.aft stack >>=? fun Eq -> - Lwt.return @@ merge_stacks loc ibody.aft stack >>=? fun _stack -> + (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun Eq -> + Lwt.return @@ merge_stacks ctxt loc ibody.aft stack >>=? fun _stack -> typed ctxt loc (Loop ibody) rest) | Failed { descr } -> let ibody = descr stack in @@ -1872,10 +1993,13 @@ and parse_instr parse_instr ?type_logger tc_context ctxt body (Item_t (tl, rest, l_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ibody -> - let unmatched_branches = Unmatched_branches (loc, ibody.aft, stack) in + let unmatched_branches () = + serialize_stack_for_error ctxt ibody.aft >>=? fun (aft, ctxt) -> + serialize_stack_for_error ctxt stack >>|? fun (stack, _ctxt) -> + Unmatched_branches (loc, aft, stack) in trace unmatched_branches - (Lwt.return @@ stack_ty_eq 1 ibody.aft stack >>=? fun Eq -> - Lwt.return @@ merge_stacks loc ibody.aft stack >>=? fun _stack -> + (Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack >>=? fun Eq -> + Lwt.return @@ merge_stacks ctxt loc ibody.aft stack >>=? fun _stack -> typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot))) | Failed { descr } -> let ibody = descr stack in @@ -1883,9 +2007,9 @@ and parse_instr end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], annot), stack -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true arg + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:true arg >>=? fun (Ex_ty arg) -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:true ret + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:true ret >>=? fun (Ex_ty ret) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_var_annot loc annot >>=? fun annot -> @@ -1912,7 +2036,7 @@ and parse_instr Item_t (v, _rest, _) -> fail_unexpected_annot loc annot >>=? fun () -> let descr aft = { loc ; instr = Failwith v ; bef = stack_ty ; aft } in - log_stack loc stack_ty Empty_t ; + log_stack ctxt loc stack_ty Empty_t >>=? fun ctxt -> return ctxt (Failed { descr }) (* timestamp operations *) | Prim (loc, I_ADD, [], annot), @@ -2268,10 +2392,10 @@ and parse_instr | Prim (loc, I_CAST, [ cast_t ], annot), Item_t (t, stack, item_annot) -> parse_var_annot loc annot ~default:item_annot >>=? fun annot -> - (Lwt.return @@ parse_ty ~allow_big_map:true ~allow_operation:true cast_t) + (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:true cast_t) >>=? fun (Ex_ty cast_t) -> - Lwt.return @@ ty_eq cast_t t >>=? fun Eq -> - Lwt.return @@ merge_types loc cast_t t >>=? fun _ -> + Lwt.return @@ ty_eq ctxt cast_t t >>=? fun Eq -> + Lwt.return @@ merge_types ctxt loc cast_t t >>=? fun _ -> typed ctxt loc Nop (Item_t (cast_t, stack, annot)) | Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _) -> @@ -2287,7 +2411,7 @@ and parse_instr (Item_t (Bytes_t None, rest, annot)) | Prim (loc, I_UNPACK, [ ty ], annot), Item_t (Bytes_t _, rest, packed_annot) -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t) -> let stack_annot = gen_access_annot packed_annot default_unpack_annot in parse_constr_annot loc annot ~if_special_first:(var_to_field_annot stack_annot) @@ -2303,7 +2427,7 @@ and parse_instr (Item_t (Address_t None, rest, annot)) | Prim (loc, I_CONTRACT, [ ty ], annot), Item_t (Address_t _, rest, addr_annot) -> - Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty >>=? fun (Ex_ty t) -> parse_var_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot) >>=? fun annot -> typed ctxt loc (Contract t) @@ -2345,12 +2469,14 @@ and parse_instr let cannonical_code = fst @@ Micheline.extract_locations code in Lwt.return @@ parse_toplevel cannonical_code >>=? fun (arg_type, storage_type, code_field) -> trace - (Ill_formed_type (Some "parameter", cannonical_code, location arg_type)) - (Lwt.return @@ parse_ty ~allow_big_map:false ~allow_operation:false arg_type) + (fun () -> Error_monad.return + (Ill_formed_type (Some "parameter", cannonical_code, location arg_type))) + (Lwt.return @@ parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type) >>=? fun (Ex_ty arg_type) -> trace - (Ill_formed_type (Some "storage", cannonical_code, location storage_type)) - (Lwt.return @@ parse_ty ~allow_big_map:true ~allow_operation:false storage_type) + (fun () -> Error_monad.return + (Ill_formed_type (Some "storage", cannonical_code, location storage_type))) + (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type) >>=? fun (Ex_ty storage_type) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in @@ -2362,17 +2488,17 @@ and parse_instr Pair_t ((List_t (Operation_t None, None), None, None), (storage_type, None, None), None) in trace - (Ill_typed_contract (cannonical_code, [])) + (fun () -> Error_monad.return (Ill_typed_contract (cannonical_code, []))) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> - Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq -> - Lwt.return @@ merge_types loc arg arg_type_full >>=? fun _ -> - Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq -> - Lwt.return @@ merge_types loc ret ret_type_full >>=? fun _ -> - Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq -> - Lwt.return @@ merge_types loc storage_type ginit >>=? fun _ -> + Lwt.return @@ ty_eq ctxt arg arg_type_full >>=? fun Eq -> + Lwt.return @@ merge_types ctxt loc arg arg_type_full >>=? fun _ -> + Lwt.return @@ ty_eq ctxt ret ret_type_full >>=? fun Eq -> + Lwt.return @@ merge_types ctxt loc ret ret_type_full >>=? fun _ -> + Lwt.return @@ ty_eq ctxt storage_type ginit >>=? fun Eq -> + Lwt.return @@ merge_types ctxt loc storage_type ginit >>=? fun _ -> typed ctxt loc (Create_contract (storage_type, arg_type, lambda)) (Item_t (Operation_t None, Item_t (Address_t None, rest, addr_annot), op_annot)) | Prim (loc, I_NOW, [], annot), @@ -2475,23 +2601,30 @@ and parse_instr | I_AND | I_OR | I_XOR | I_LSL | I_LSR | I_CONCAT | I_COMPARE as name), [], _), Item_t (ta, Item_t (tb, _, _), _) -> + Lwt.return @@ serialize_ty_for_error ctxt ta >>=? fun (ta, ctxt) -> + Lwt.return @@ serialize_ty_for_error ctxt tb >>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb)) | Prim (loc, (I_NEG | I_ABS | I_NOT | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), [], _), Item_t (t, _, _) -> + Lwt.return @@ serialize_ty_for_error ctxt t >>=? fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t)) | Prim (loc, I_UPDATE, [], _), stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_UPDATE, 3, stack)) | Prim (loc, I_CREATE_CONTRACT, [], _), stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack)) | Prim (loc, I_CREATE_ACCOUNT, [], _), stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack)) | Prim (loc, I_TRANSFER_TOKENS, [], _), stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack)) | Prim (loc, (I_DROP | I_DUP | I_CAR | I_CDR | I_SOME | I_BLAKE2B | I_SHA256 | I_SHA512 | I_DIP @@ -2500,6 +2633,7 @@ and parse_instr | I_NEG | I_ABS | I_INT | I_NOT | I_HASH_KEY | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), _, _), stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 1, stack)) | Prim (loc, (I_SWAP | I_PAIR | I_CONS | I_GET | I_MEM | I_EXEC @@ -2507,6 +2641,7 @@ and parse_instr | I_EDIV | I_AND | I_OR | I_XOR | I_LSL | I_LSR | I_CONCAT as name), _, _), stack -> + serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack)) (* Generic parsing errors *) | expr, _ -> @@ -2541,11 +2676,11 @@ and parse_contract | true -> Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script >>=? fun ctxt -> trace - (Invalid_contract (loc, contract)) @@ + (fun () -> return (Invalid_contract (loc, contract))) @@ Contract.get_script ctxt contract >>=? fun (ctxt, script) -> match script with | None -> Lwt.return - (ty_eq arg (Unit_t None) >>? fun Eq -> + (ty_eq ctxt arg (Unit_t None) >>? fun Eq -> let contract : arg typed_contract = (arg, contract) in ok (ctxt, contract)) | Some { code ; _ } -> @@ -2553,16 +2688,16 @@ and parse_contract (Script.force_decode code >>? fun (code, cost_code) -> Gas.consume ctxt cost_code >>? fun ctxt -> parse_toplevel code >>? fun (arg_type, _, _) -> - parse_ty ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ) -> - ty_eq targ arg >>? fun Eq -> - merge_types loc targ arg >>? fun arg -> + parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type >>? fun (Ex_ty targ) -> + ty_eq ctxt targ arg >>? fun Eq -> + merge_types ctxt loc targ arg >>? fun arg -> let contract : arg typed_contract = (arg, contract) in ok (ctxt, contract)) and parse_toplevel : Script.expr -> (Script.node * Script.node * Script.node) tzresult = fun toplevel -> - record_trace (Ill_typed_contract (toplevel, [])) @@ + record_trace (fun () -> ok (Ill_typed_contract (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)) @@ -2613,12 +2748,12 @@ let parse_script Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt -> Lwt.return @@ parse_toplevel code >>=? fun (arg_type, storage_type, code_field) -> trace - (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false arg_type)) + (fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type))) + (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) >>=? fun (Ex_ty arg_type) -> trace - (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false storage_type)) + (fun () -> return (Ill_formed_type (Some "storage", code, location storage_type))) + (Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type)) >>=? fun (Ex_ty storage_type) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in @@ -2630,10 +2765,12 @@ let parse_script Pair_t ((List_t (Operation_t None, None), None, None), (storage_type, None, None), None) in trace - (Ill_typed_data (None, storage, storage_type)) + (fun () -> + Lwt.return @@ serialize_ty_for_error ctxt storage_type >>|? fun (storage_type, _ctxt) -> + Ill_typed_data (None, storage, storage_type)) (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> trace - (Ill_typed_contract (code, [])) + (fun () -> return (Ill_typed_contract (code, []))) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt) @@ -2645,12 +2782,12 @@ let typecheck_code let type_map = ref [] in (* TODO: annotation checking *) trace - (Ill_formed_type (Some "parameter", code, location arg_type)) - (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false arg_type)) + (fun () -> return (Ill_formed_type (Some "parameter", code, location arg_type))) + (Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false arg_type)) >>=? fun (Ex_ty arg_type) -> trace - (Ill_formed_type (Some "storage", code, location storage_type)) - (Lwt.return (parse_ty ~allow_big_map:true ~allow_operation:false storage_type)) + (fun () -> return (Ill_formed_type (Some "storage", code, location storage_type))) + (Lwt.return (parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type)) >>=? fun (Ex_ty storage_type) -> let arg_annot = default_annot (type_to_var_annot (name_of_ty arg_type)) ~default:default_param_annot in @@ -2668,7 +2805,7 @@ let typecheck_code ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) (arg_type_full, None) ret_type_full code_field in trace - (Ill_typed_contract (code, !type_map)) + (fun () -> return (Ill_typed_contract (code, !type_map))) result >>=? fun (Lam _, ctxt) -> return (!type_map, ctxt) @@ -2677,18 +2814,18 @@ let typecheck_data context -> Script.expr * Script.expr -> context tzresult Lwt.t = fun ?type_logger ctxt (data, exp_ty) -> trace - (Ill_formed_type (None, exp_ty, 0)) - (Lwt.return @@ parse_ty ~allow_big_map:true ~allow_operation:false (root exp_ty)) + (fun () -> return (Ill_formed_type (None, exp_ty, 0))) + (Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false (root exp_ty)) >>=? fun (Ex_ty exp_ty) -> trace - (Ill_typed_data (None, data, exp_ty)) + (fun () -> + Lwt.return @@ serialize_ty_for_error ctxt exp_ty >>|? fun (exp_ty, _ctxt) -> + Ill_typed_data (None, data, exp_ty)) (parse_data ?type_logger ctxt exp_ty (root data)) >>=? fun (_, ctxt) -> return ctxt (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) -module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse - let rec unparse_data : type a. context -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t = fun ctxt mode ty a -> @@ -2837,7 +2974,7 @@ let rec unparse_data and unparse_code ctxt mode = function | Prim (loc, I_PUSH, [ ty ; data ], annot) -> - Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t) -> + Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t) -> parse_data ctxt t data >>=? fun (data, ctxt) -> unparse_data ctxt mode t data >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) @@ -2861,8 +2998,8 @@ let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = let Lam (_, original_code) = code in unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) -> unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> - let arg_type = unparse_ty arg_type in - let storage_type = unparse_ty storage_type in + unparse_ty ctxt arg_type >>=? fun (arg_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (storage_type, ctxt) -> let open Micheline in let code = Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ; @@ -2876,10 +3013,12 @@ let pack_data ctxt typ data = let unparsed = strip_annotations @@ data in let bytes = Data_encoding.Binary.to_bytes_exn expr_encoding (Micheline.strip_locations unparsed) in let bytes = MBytes.concat "" [ MBytes.of_string "\005" ; bytes ] in + Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes) >>=? fun ctxt -> return (bytes, ctxt) let hash_data ctxt typ data = pack_data ctxt typ data >>=? fun (bytes, ctxt) -> + Lwt.return @@ Gas.consume ctxt (Michelson_v1_gas.Cost_of.hash bytes 32) >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [ bytes ]), ctxt) (* ---------------- Big map -------------------------------------------------*) @@ -2940,7 +3079,7 @@ let erase_big_map_initialization ctxt mode ({ code ; storage } : Script.t) = Lwt.return @@ Script.force_decode storage >>=? fun (storage, cost_storage) -> Lwt.return @@ Gas.consume ctxt cost_storage >>=? fun ctxt -> Lwt.return @@ parse_toplevel code >>=? fun (_, storage_type, _) -> - Lwt.return @@ parse_ty ~allow_big_map:true ~allow_operation:false storage_type >>=? fun (Ex_ty ty) -> + Lwt.return @@ parse_ty ctxt ~allow_big_map:true ~allow_operation:false storage_type >>=? fun (Ex_ty ty) -> parse_data ctxt ty (Micheline.root storage) >>=? fun (storage, ctxt) -> begin 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 e478681e6..97b022f8d 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -57,6 +57,7 @@ val big_map_update : ('key, 'value) Script_typed_ir.big_map val ty_eq : + context -> 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> ('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq tzresult @@ -69,13 +70,16 @@ val unparse_data : (Script.node * context) tzresult Lwt.t val parse_ty : + context -> allow_big_map: bool -> allow_operation: bool -> Script.node -> ex_ty tzresult -val unparse_ty : 'a Script_typed_ir.ty -> Script.node -val parse_toplevel - : Script.expr -> (Script.node * Script.node * Script.node) tzresult +val unparse_ty : + context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t + +val parse_toplevel : + Script.expr -> (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.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml index 0100e835b..ac3779fa5 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml @@ -9,7 +9,6 @@ open Alpha_context open Script -open Script_typed_ir (* ---- Error definitions ---------------------------------------------------*) @@ -17,7 +16,8 @@ open Script_typed_ir (* Auxiliary types for error documentation *) type namespace = Type_namespace | Constant_namespace | Instr_namespace | Keyword_namespace type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind -type type_map = (int * ((Script.expr * Script.annot) list * (Script.expr * Script.annot) list)) list +type unparsed_stack_ty = (Script.expr * Script.annot) list +type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list (* Structure errors *) type error += Invalid_arity of Script.location * prim * int * int @@ -31,35 +31,38 @@ type error += Unexpected_operation of Script.location (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location -type error += Undefined_binop : Script.location * prim * _ ty * _ ty -> error -type error += Undefined_unop : Script.location * prim * _ ty -> error -type error += Bad_return : Script.location * _ stack_ty * _ ty -> error -type error += Bad_stack : Script.location * prim * int * _ stack_ty -> error -type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty -> error +type error += Undefined_binop : Script.location * prim * Script.expr * Script.expr -> error +type error += Undefined_unop : Script.location * prim * Script.expr -> error +type error += Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error +type error += Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error +type error += Unmatched_branches : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error type error += Self_in_lambda of Script.location type error += Bad_stack_length type error += Bad_stack_item of int type error += Inconsistent_annotations of string * string -type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error +type error += Inconsistent_type_annotations : Script.location * Script.expr * Script.expr -> error type error += Inconsistent_field_annotations of string * string type error += Unexpected_annotation of Script.location type error += Ungrouped_annotations of Script.location -type error += Invalid_map_body : Script.location * _ stack_ty -> error +type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error type error += Invalid_map_block_fail of Script.location -type error += Invalid_iter_body : Script.location * _ stack_ty * _ stack_ty -> error +type error += Invalid_iter_body : Script.location * unparsed_stack_ty * unparsed_stack_ty -> error type error += Type_too_large : Script.location * int * int -> error (* Value typing errors *) -type error += Invalid_constant : Script.location * Script.expr * _ ty -> error +type error += Invalid_constant : Script.location * Script.expr * Script.expr -> error type error += Invalid_contract of Script.location * Contract.t -type error += Comparable_type_expected : Script.location * _ ty -> error -type error += Inconsistent_types : _ ty * _ ty -> error +type error += Comparable_type_expected : Script.location * Script.expr -> error +type error += Inconsistent_types : Script.expr * Script.expr -> error type error += Unordered_map_keys of Script.location * Script.expr type error += Unordered_set_values of Script.location * Script.expr type error += Duplicate_map_keys of Script.location * Script.expr type error += Duplicate_set_values of Script.location * Script.expr (* Toplevel errors *) -type error += Ill_typed_data : string option * Script.expr * _ ty -> error +type error += Ill_typed_data : string option * Script.expr * Script.expr -> error type error += Ill_formed_type of string option * Script.expr * Script.location type error += Ill_typed_contract : Script.expr * type_map -> error + +(* Gas related errors *) +type error += Cannot_serialize_error 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 b00338de0..abd86bb05 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 @@ -8,11 +8,8 @@ (**************************************************************************) open Alpha_context -open Micheline open Script -open Script_typed_ir open Script_tc_errors -open Script_ir_translator (* Helpers for encoding *) let type_map_enc = @@ -27,49 +24,12 @@ let type_map_enc = (req "stackBefore" stack_enc) (req "stackAfter" stack_enc))) -let rec strip_var_annots = function - | Int _ | String _ | Bytes _ as atom -> atom - | Seq (loc, args) -> Seq (loc, List.map strip_var_annots args) - | Prim (loc, name, args, annots) -> - let not_var_annot s = Compare.Char.(String.get s 0 <> '@') in - let annots = List.filter not_var_annot annots in - Prim (loc, name, List.map strip_var_annots args, annots) - -let ex_ty_enc = - Data_encoding.conv - (fun (Ex_ty ty) -> - strip_locations (strip_var_annots (unparse_ty ty))) - (fun expr -> - match parse_ty ~allow_big_map:true ~allow_operation:true (root expr) with - | Ok ty -> ty - | _ -> assert false) - Script.expr_encoding - -let var_annot_enc = +let stack_ty_enc = let open Data_encoding in - conv - (function `Var_annot x -> "@" ^ x) - (function x -> - assert (Compare.Int.(String.length x > 0) && Compare.Char.(String.get x 0 = '@')) ; - `Var_annot (String.sub x 1 (String.length x - 1))) - string - -let ex_stack_ty_enc = - let open Data_encoding in - let rec unfold = function - | Ex_stack_ty (Item_t (ty, rest, annot)) -> - (Ex_ty ty, annot) :: unfold (Ex_stack_ty rest) - | Ex_stack_ty Empty_t -> [] in - let rec fold = function - | (Ex_ty ty, annot) :: rest -> - let Ex_stack_ty rest = fold rest in - Ex_stack_ty (Item_t (ty, rest, annot)) - | [] -> Ex_stack_ty Empty_t in - conv unfold fold - (list - (obj2 - (req "type" ex_ty_enc) - (opt "annot" var_annot_enc))) + (list + (obj2 + (req "type" Script.expr_encoding) + (dft "annots" (list string) []))) (* main registration *) let () = @@ -290,13 +250,13 @@ let () = over which it is not defined." (located (obj3 (req "operatorName" prim_encoding) - (req "wrongLeftOperandType" ex_ty_enc) - (req "wrongRightOperandType" ex_ty_enc))) + (req "wrongLeftOperandType" Script.expr_encoding) + (req "wrongRightOperandType" Script.expr_encoding))) (function | Undefined_binop (loc, n, tyl, tyr) -> - Some (loc, (n, Ex_ty tyl, Ex_ty tyr)) + Some (loc, (n, tyl, tyr)) | _ -> None) - (fun (loc, (n, Ex_ty tyl, Ex_ty tyr)) -> + (fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ; (* Undefined unary operation *) register_error_kind @@ -308,12 +268,12 @@ let () = over which it is not defined." (located (obj2 (req "operatorName" prim_encoding) - (req "wrongOperandType" ex_ty_enc))) + (req "wrongOperandType" Script.expr_encoding))) (function | Undefined_unop (loc, n, ty) -> - Some (loc, (n, Ex_ty ty)) + Some (loc, (n, ty)) | _ -> None) - (fun (loc, (n, Ex_ty ty)) -> + (fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ; (* Bad return *) register_error_kind @@ -323,12 +283,12 @@ let () = ~description: "Unexpected stack at the end of a lambda or script." (located (obj2 - (req "expectedReturnType" ex_ty_enc) - (req "wrongStackType" ex_stack_ty_enc))) + (req "expectedReturnType" Script.expr_encoding) + (req "wrongStackType" stack_ty_enc))) (function - | Bad_return (loc, sty, ty) -> Some (loc, (Ex_ty ty, Ex_stack_ty sty)) + | Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None) - (fun (loc, (Ex_ty ty, Ex_stack_ty sty)) -> + (fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ; (* Bad stack *) register_error_kind @@ -340,11 +300,11 @@ let () = (located (obj3 (req "primitiveName" prim_encoding) (req "relevantStackPortion" int16) - (req "wrongStackType" ex_stack_ty_enc))) + (req "wrongStackType" stack_ty_enc))) (function - | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, Ex_stack_ty sty)) + | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None) - (fun (loc, (name, s, Ex_stack_ty sty)) -> + (fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ; (* Inconsistent annotations *) register_error_kind @@ -377,12 +337,12 @@ let () = ~title:"Types contain inconsistent annotations" ~description:"The two types contain annotations that do not match" (located (obj2 - (req "type1" ex_ty_enc) - (req "type2" ex_ty_enc))) + (req "type1" Script.expr_encoding) + (req "type2" Script.expr_encoding))) (function - | Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (Ex_ty ty1, Ex_ty ty2)) + | Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (ty1, ty2)) | _ -> None) - (fun (loc, (Ex_ty ty1, Ex_ty ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ; + (fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ; (* Unexpected annotation *) register_error_kind `Permanent @@ -412,13 +372,13 @@ let () = "At the join point at the end of two code branches \ the stacks have inconsistent lengths or contents." (located (obj2 - (req "firstStackType" ex_stack_ty_enc) - (req "otherStackType" ex_stack_ty_enc))) + (req "firstStackType" stack_ty_enc) + (req "otherStackType" stack_ty_enc))) (function | Unmatched_branches (loc, stya, styb) -> - Some (loc, (Ex_stack_ty stya, Ex_stack_ty styb)) + Some (loc, (stya, styb)) | _ -> None) - (fun (loc, (Ex_stack_ty stya, Ex_stack_ty styb)) -> + (fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ; (* Bad stack item *) register_error_kind @@ -470,13 +430,13 @@ let () = ~description: "A data expression was invalid for its expected type." (located (obj2 - (req "expectedType" ex_ty_enc) + (req "expectedType" Script.expr_encoding) (req "wrongExpression" Script.expr_encoding))) (function | Invalid_constant (loc, expr, ty) -> - Some (loc, (Ex_ty ty, expr)) + Some (loc, (ty, expr)) | _ -> None) - (fun (loc, (Ex_ty ty, expr)) -> + (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ; (* Invalid contract *) register_error_kind @@ -501,11 +461,11 @@ let () = ~description: "A non comparable type was used in a place where \ only comparable types are accepted." - (located (obj1 (req "wrongType" ex_ty_enc))) + (located (obj1 (req "wrongType" Script.expr_encoding))) (function - | Comparable_type_expected (loc, ty) -> Some (loc, Ex_ty ty) + | Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None) - (fun (loc, Ex_ty ty) -> + (fun (loc, ty) -> Comparable_type_expected (loc, ty)) ; (* Inconsistent types *) register_error_kind @@ -518,14 +478,12 @@ let () = two types have to be proven, it is always accompanied \ with another error that provides more context." (obj2 - (req "firstType" ex_ty_enc) - (req "otherType" ex_ty_enc)) + (req "firstType" Script.expr_encoding) + (req "otherType" Script.expr_encoding)) (function - | Inconsistent_types (tya, tyb) -> - Some (Ex_ty tya, Ex_ty tyb) + | Inconsistent_types (tya, tyb) -> Some (tya, tyb) | _ -> None) - (fun (Ex_ty tya, Ex_ty tyb) -> - Inconsistent_types (tya, tyb)) ; + (fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ; (* -- Instruction typing errors ------------------- *) (* Invalid map body *) register_error_kind @@ -536,13 +494,11 @@ let () = "The body of a map block did not match the expected type" (obj2 (req "loc" Script.location_encoding) - (req "bodyType" ex_stack_ty_enc)) + (req "bodyType" stack_ty_enc)) (function - | Invalid_map_body (loc, stack) -> - Some (loc, Ex_stack_ty stack) + | Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None) - (fun (loc, Ex_stack_ty stack) -> - Invalid_map_body (loc, stack)) ; + (fun (loc, stack) -> Invalid_map_body (loc, stack)) ; (* Invalid map block FAIL *) register_error_kind `Permanent @@ -565,12 +521,12 @@ let () = the ITER." (obj3 (req "loc" Script.location_encoding) - (req "befStack" ex_stack_ty_enc) - (req "aftStack" ex_stack_ty_enc)) + (req "befStack" stack_ty_enc) + (req "aftStack" stack_ty_enc)) (function - | Invalid_iter_body (loc, bef, aft) -> Some (loc, Ex_stack_ty bef, Ex_stack_ty aft) + | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None) - (fun (loc, Ex_stack_ty bef, Ex_stack_ty aft) -> Invalid_iter_body (loc, bef, aft)) ; + (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ; (* Type too large *) register_error_kind `Permanent @@ -597,13 +553,12 @@ let () = (always followed by more precise errors)." (obj3 (opt "identifier" string) - (req "expectedType" ex_ty_enc) + (req "expectedType" Script.expr_encoding) (req "illTypedExpression" Script.expr_encoding)) (function - | Ill_typed_data (name, expr, ty) -> Some (name, Ex_ty ty, expr) + | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None) - (fun (name, Ex_ty ty, expr) -> - Ill_typed_data (name, expr, ty)) ; + (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ; (* Ill formed type *) register_error_kind `Permanent @@ -638,4 +593,14 @@ let () = Some (expr, type_map) | _ -> None) (fun (expr, type_map) -> - Ill_typed_contract (expr, type_map)) + Ill_typed_contract (expr, type_map)) ; + (* Cannot serialize error *) + register_error_kind + `Temporary + ~id:"cannotSerializeError" + ~title:"Not enough gas to serialize error" + ~description:"The error was too big to be serialized with \ + the provided gas" + Data_encoding.empty + (function Cannot_serialize_error -> Some () | _ -> None) + (fun () -> Cannot_serialize_error)