From bc88ede900232b7259c1db2b89cd27ec38a0b4d9 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 24 May 2018 09:43:15 +0200 Subject: [PATCH] Michelson: FAIL as a macro --- .../lib_client/michelson_v1_error_reporter.ml | 13 +---- .../lib_client/michelson_v1_macros.ml | 51 ++++++++++++++++--- .../test/test_michelson_parser.ml | 14 ++++- .../lib_protocol/src/alpha_context.mli | 1 - .../src/michelson_v1_primitives.ml | 4 -- .../src/michelson_v1_primitives.mli | 1 - .../lib_protocol/src/script_interpreter.ml | 7 ++- .../lib_protocol/src/script_interpreter.mli | 2 +- .../lib_protocol/src/script_ir_translator.ml | 12 +---- .../lib_protocol/src/script_typed_ir.ml | 2 - 10 files changed, 62 insertions(+), 45 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 0d7317a30..081518b00 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -431,18 +431,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = @[is not compatible with type@ %a.@]@]" print_ty tya print_ty tyb - | Reject (loc, None, trace) -> - Format.fprintf ppf - "%ascript reached FAIL instruction@ \ - %a" - print_loc loc - (fun ppf -> function - | None -> () - | Some trace -> - Format.fprintf ppf "@,@[trace@,%a@]" - print_execution_trace trace) - trace - | Reject (loc, Some v, trace) -> + | Reject (loc, v, trace) -> Format.fprintf ppf "%ascript reached FAILWITH instruction@ \ @[with@ %a@]%a" diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.ml b/src/proto_alpha/lib_client/michelson_v1_macros.ml index 5256e31c8..781b3ef8f 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/michelson_v1_macros.ml @@ -577,6 +577,14 @@ let expand_if_right = function error (Invalid_arity ("IF_RIGHT", List.length args, 2)) | _ -> ok @@ None +let expand_fail = function + | Prim (loc, "FAIL", [], []) -> + ok @@ Some (Seq (loc, [ + Prim (loc, "UNIT", [], []) ; + Prim (loc, "FAILWITH", [], []) ; + ])) + | _ -> ok @@ None + let expand original = let rec try_expansions = function | [] -> ok @@ original @@ -598,6 +606,7 @@ let expand original = expand_asserts ; expand_if_some ; expand_if_right ; + expand_fail ; ] let expand_rec expr = @@ -965,32 +974,49 @@ let unexpand_compare expanded = let unexpand_asserts expanded = match expanded with | Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ Prim(_, "FAIL", [], []) ]) ], + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], []) ]) -> Some (Prim (loc, "ASSERT", [], [])) | Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ; Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], []) ]) -> Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], [])) | Seq (loc, [ Prim (_, comparison, [], []) ; Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], []) ]) -> Some (Prim (loc, "ASSERT_" ^ comparison, [], [])) | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ; - Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], []) ]) -> Some (Prim (loc, "ASSERT_NONE", [], [])) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ; + | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ; Seq (_, [])], []) ]) -> Some (Prim (loc, "ASSERT_SOME", [], [])) | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ; - Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], []) ]) -> Some (Prim (loc, "ASSERT_LEFT", [], [])) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ; + | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ; Seq (_, []) ], []) ]) -> Some (Prim (loc, "ASSERT_RIGHT", [], [])) @@ -1007,6 +1033,14 @@ let unexpand_if_right = function Some (Prim (loc, "IF_RIGHT", [ right ; left ], annot)) | _ -> None +let unexpand_fail = function + | Seq (loc, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ; + ]) -> + Some (Prim (loc, "FAIL", [], [])) + | _ -> None + let unexpand original = let try_unexpansions unexpanders = match @@ -1029,7 +1063,8 @@ let unexpand original = unexpand_duuuuup ; unexpand_compare ; unexpand_if_some ; - unexpand_if_right ] + unexpand_if_right ; + unexpand_fail ] let rec unexpand_rec expr = match unexpand expr with diff --git a/src/proto_alpha/lib_delegate/test/test_michelson_parser.ml b/src/proto_alpha/lib_delegate/test/test_michelson_parser.ml index 5d5a82d37..48aebdfe0 100644 --- a/src/proto_alpha/lib_delegate/test/test_michelson_parser.ml +++ b/src/proto_alpha/lib_delegate/test/test_michelson_parser.ml @@ -196,11 +196,21 @@ let test_expansion () = assert_expands (Prim (zero_loc, "ASSERT_LEFT", [], [])) (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", [ Seq (zero_loc, []) ; - Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ], + Seq (zero_loc, [ + Seq (zero_loc, [ + Prim(zero_loc, "UNIT", [], []) ; + Prim(zero_loc, "FAILWITH", [], []) + ]) + ]) ], []) ])) >>? fun () -> assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], [])) (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", - [ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ; + [ Seq (zero_loc, [ + Seq (zero_loc, [ + Prim(zero_loc, "UNIT", [], []) ; + Prim(zero_loc, "FAILWITH", [], []) + ]) + ]) ; Seq (zero_loc, []) ], []) ])) >>? fun () -> assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], [])) diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index ff24eade8..9a7d40b58 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -200,7 +200,6 @@ module Script : sig | I_EMPTY_SET | I_EQ | I_EXEC - | I_FAIL | I_FAILWITH | I_GE | I_GET diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml index 142004187..68edec0a5 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml @@ -49,7 +49,6 @@ type prim = | I_EMPTY_SET | I_EQ | I_EXEC - | I_FAIL | I_FAILWITH | I_GE | I_GET @@ -177,7 +176,6 @@ let string_of_prim = function | I_EMPTY_SET -> "EMPTY_SET" | I_EQ -> "EQ" | I_EXEC -> "EXEC" - | I_FAIL -> "FAIL" | I_FAILWITH -> "FAILWITH" | I_GE -> "GE" | I_GET -> "GET" @@ -286,7 +284,6 @@ let prim_of_string = function | "EMPTY_SET" -> ok I_EMPTY_SET | "EQ" -> ok I_EQ | "EXEC" -> ok I_EXEC - | "FAIL" -> ok I_FAIL | "FAILWITH" -> ok I_FAILWITH | "GE" -> ok I_GE | "GET" -> ok I_GET @@ -440,7 +437,6 @@ let prim_encoding = ("EMPTY_SET", I_EMPTY_SET) ; ("EQ", I_EQ) ; ("EXEC", I_EXEC) ; - ("FAIL", I_FAIL) ; ("FAILWITH", I_FAILWITH) ; ("GE", I_GE) ; ("GET", I_GET) ; diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli index f1e0ceaf6..61dde618f 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli @@ -47,7 +47,6 @@ type prim = | I_EMPTY_SET | I_EQ | I_EXEC - | I_FAIL | I_FAILWITH | I_GE | I_GET diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index 50f8abe2b..4360d6171 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -17,7 +17,7 @@ open Script_ir_translator type execution_trace = (Script.location * Gas.t * (Script.expr * string option) list) list -type error += Reject of Script.location * Script.expr option * execution_trace option +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 *) @@ -41,7 +41,7 @@ let () = ~description: "A FAILWITH instruction was reached" (obj3 (req "location" Script.location_encoding) - (opt "with" Script.expr_encoding) + (req "with" Script.expr_encoding) (opt "trace" trace_encoding)) (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None) (fun (loc, v, trace) -> Reject (loc, v, trace)); @@ -543,11 +543,10 @@ let rec interp | Lambda lam, rest -> Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> logged_return (Item (lam, rest), ctxt) - fail (Reject (loc, None, get_log log)) | Failwith tv, Item (v, _) -> unparse_data ctxt Optimized tv v >>=? fun (v, _ctxt) -> let v = Micheline.strip_locations v in - fail (Reject (loc, Some v, get_log log)) + fail (Reject (loc, v, get_log log)) | Nop, stack -> logged_return (stack, ctxt) (* comparison *) diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli index 8179a5e52..9661f7cb6 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli @@ -12,7 +12,7 @@ open Alpha_context type execution_trace = (Script.location * Gas.t * (Script.expr * string option) list) list -type error += Reject of Script.location * Script.expr option * execution_trace option +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 *) 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 4ca7e6699..44a8dfaa3 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -182,7 +182,6 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Dip _ -> 0 | Exec -> 0 | Lambda _ -> 1 - | Fail -> 1 | Failwith _ -> 1 | Nop -> 0 | Compare _ -> 1 @@ -261,7 +260,6 @@ let namespace = function | I_EMPTY_SET | I_EQ | I_EXEC - | I_FAIL | I_FAILWITH | I_GE | I_GET @@ -1887,12 +1885,6 @@ and parse_instr | Failed _ -> fail (Fail_not_in_tail_position loc) end - | Prim (loc, I_FAIL, [], annot), - bef -> - fail_unexpected_annot loc annot >>=? fun () -> - let descr aft = { loc ; instr = Fail; bef ; aft } in - log_stack loc stack_ty Empty_t ; - return ctxt (Failed { descr } ) | Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _) -> fail_unexpected_annot loc annot >>=? fun () -> @@ -2402,7 +2394,7 @@ and parse_instr | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT | I_PAIR | I_CAR | I_CDR | I_CONS | I_MEM | I_UPDATE | I_MAP - | I_GET | I_EXEC | I_FAIL | I_SIZE + | I_GET | I_EXEC | I_FAILWITH | I_SIZE | I_CONCAT | I_ADD | I_SUB | I_MUL | I_EDIV | I_OR | I_AND | I_XOR | I_NOT @@ -2472,7 +2464,7 @@ and parse_instr [ I_DROP ; I_DUP ; I_SWAP ; I_SOME ; I_UNIT ; I_PAIR ; I_CAR ; I_CDR ; I_CONS ; I_MEM ; I_UPDATE ; I_MAP ; I_ITER ; - I_GET ; I_EXEC ; I_FAIL ; I_SIZE ; + I_GET ; I_EXEC ; I_FAILWITH ; I_SIZE ; I_CONCAT ; I_ADD ; I_SUB ; I_MUL ; I_EDIV ; I_OR ; I_AND ; I_XOR ; I_NOT ; diff --git a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml index 3f575cd32..7dab0497c 100644 --- a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml @@ -292,8 +292,6 @@ and ('bef, 'aft) instr = ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr - | Fail : - ('bef, 'aft) instr | Failwith : 'a ty -> ('a * 'rest, 'aft) instr | Nop :