From 871a86e32ddfa84c25a324b8c126c8ee4dc041ae Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 27 Apr 2018 19:28:50 +0200 Subject: [PATCH] Michelson: instruction FAILWITH which takes one element on the stack --- src/bin_client/test/contracts/accounts.tz | 9 ++++--- .../lib_client/michelson_v1_error_reporter.ml | 15 +++++++++-- .../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 | 18 +++++++------ .../lib_protocol/src/script_interpreter.mli | 2 +- .../lib_protocol/src/script_ir_translator.ml | 25 +++++++++++++------ .../lib_protocol/src/script_typed_ir.ml | 2 ++ 9 files changed, 56 insertions(+), 21 deletions(-) diff --git a/src/bin_client/test/contracts/accounts.tz b/src/bin_client/test/contracts/accounts.tz index a0800c188..63d127c09 100644 --- a/src/bin_client/test/contracts/accounts.tz +++ b/src/bin_client/test/contracts/accounts.tz @@ -26,18 +26,19 @@ code { DUP; CAR; CAR %from; DIIP{ CDAR %withdraw_amount; H @signed_amount }; DIP{ CDDR %sig }; CHECK_SIGNATURE; - IF {} { FAIL }; + IF {} { PUSH string "Bad signature"; FAILWITH }; # Get user account information DIIP{ CDR %stored_balance; DUP }; - CAR %from; HASH_KEY @from_hash; DIP{ SWAP }; GET; + CAR %from; HASH_KEY @from_hash; DUP; DIP{ DIP { SWAP }; SWAP}; GET; # Account does not exist - IF_NONE { FAIL } + IF_NONE { PUSH string "Account does not exist"; PAIR; FAILWITH } # Account exists { RENAME @previous_balance; + DIP { DROP }; DUP; DIIP{ DUP; CDAR %withdraw_amount; DUP }; # Ensure funds are available DIP{ CMPLT @not_enough }; SWAP; - IF { FAIL } + IF { PUSH string "Not enough funds"; FAILWITH } { SUB @new_balance; DIP{ DUP; DIP{ SWAP }}; DUP; # Delete account if balance is 0 PUSH @zero mutez 0; CMPEQ @null_balance; 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 218d94b89..0d7317a30 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -91,7 +91,7 @@ let collect_error_locations errs = | Invalid_contract (loc, _) | Comparable_type_expected (loc, _) | Overflow (loc, _) - | Reject (loc, _)) :: rest -> + | Reject (loc, _, _)) :: rest -> collect (loc :: acc) rest | _ :: rest -> collect acc rest in collect [] errs @@ -431,7 +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, trace) -> + | Reject (loc, None, trace) -> Format.fprintf ppf "%ascript reached FAIL instruction@ \ %a" @@ -442,6 +442,17 @@ let report_errors ~details ~show_source ?parsed ppf errs = Format.fprintf ppf "@,@[trace@,%a@]" print_execution_trace trace) trace + | Reject (loc, Some v, trace) -> + Format.fprintf ppf + "%ascript reached FAILWITH instruction@ \ + @[with@ %a@]%a" + print_loc loc print_expr v + (fun ppf -> function + | None -> () + | Some trace -> + Format.fprintf ppf "@,@[trace@,%a@]" + print_execution_trace trace) + trace | Overflow (loc, trace) -> Format.fprintf ppf "%aunexpected arithmetic overflow%a" print_loc loc diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli index 0442464b4..ff24eade8 100644 --- a/src/proto_alpha/lib_protocol/src/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli @@ -201,6 +201,7 @@ module Script : sig | I_EQ | I_EXEC | I_FAIL + | I_FAILWITH | I_GE | I_GET | I_GT 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 b29fd5670..142004187 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml @@ -50,6 +50,7 @@ type prim = | I_EQ | I_EXEC | I_FAIL + | I_FAILWITH | I_GE | I_GET | I_GT @@ -177,6 +178,7 @@ let string_of_prim = function | I_EQ -> "EQ" | I_EXEC -> "EXEC" | I_FAIL -> "FAIL" + | I_FAILWITH -> "FAILWITH" | I_GE -> "GE" | I_GET -> "GET" | I_GT -> "GT" @@ -285,6 +287,7 @@ let prim_of_string = function | "EQ" -> ok I_EQ | "EXEC" -> ok I_EXEC | "FAIL" -> ok I_FAIL + | "FAILWITH" -> ok I_FAILWITH | "GE" -> ok I_GE | "GET" -> ok I_GET | "GT" -> ok I_GT @@ -438,6 +441,7 @@ let prim_encoding = ("EQ", I_EQ) ; ("EXEC", I_EXEC) ; ("FAIL", I_FAIL) ; + ("FAILWITH", I_FAILWITH) ; ("GE", I_GE) ; ("GET", I_GET) ; ("GT", I_GT) ; 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 8270689f3..f1e0ceaf6 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli @@ -48,6 +48,7 @@ type prim = | I_EQ | I_EXEC | I_FAIL + | I_FAILWITH | I_GE | I_GET | I_GT diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index 97199d584..50f8abe2b 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 * execution_trace option +type error += Reject of Script.location * Script.expr option * 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 *) @@ -38,12 +38,13 @@ let () = `Temporary ~id:"scriptRejectedRuntimeError" ~title: "Script failed (runtime script error)" - ~description: "A FAIL instruction was reached" - (obj2 + ~description: "A FAILWITH instruction was reached" + (obj3 (req "location" Script.location_encoding) + (opt "with" Script.expr_encoding) (opt "trace" trace_encoding)) - (function Reject (loc, trace) -> Some (loc, trace) | _ -> None) - (fun (loc, trace) -> Reject (loc, trace)); + (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None) + (fun (loc, v, trace) -> Reject (loc, v, trace)); (* Overflow *) register_error_kind `Temporary @@ -542,8 +543,11 @@ let rec interp | Lambda lam, rest -> Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> logged_return (Item (lam, rest), ctxt) - | Fail, _ -> - fail (Reject (loc, get_log log)) + 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)) | 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 7fbf69a5c..8179a5e52 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 * execution_trace option +type error += Reject of Script.location * Script.expr option * 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 137633bf4..4ca7e6699 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -183,6 +183,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function | Exec -> 0 | Lambda _ -> 1 | Fail -> 1 + | Failwith _ -> 1 | Nop -> 0 | Compare _ -> 1 | Eq -> 0 @@ -261,6 +262,7 @@ let namespace = function | I_EQ | I_EXEC | I_FAIL + | I_FAILWITH | I_GE | I_GET | I_GT @@ -1454,13 +1456,15 @@ and parse_instr 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 _) -> () + | Some log, (Prim _ | Seq _) -> + log loc (unparse_stack stack_ty) (unparse_stack aft) + in let typed ctxt loc instr aft = - begin match type_logger, script_instr with - | None, _ - | Some _, (Seq (-1, _) | Int _ | String _) -> () - | Some log, (Prim _ | Seq _) -> - log loc (unparse_stack stack_ty) (unparse_stack aft) - end ; + log_stack loc stack_ty aft ; return ctxt (Typed { loc ; instr ; bef = stack_ty ; aft }) in match script_instr, stack_ty with (* stack ops *) @@ -1886,7 +1890,14 @@ and parse_instr | Prim (loc, I_FAIL, [], annot), bef -> fail_unexpected_annot loc annot >>=? fun () -> - let descr aft = { loc ; instr = Fail ; bef ; aft } in + 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 () -> + let descr aft = { loc ; instr = Failwith v ; bef = stack_ty ; aft } in + log_stack loc stack_ty Empty_t ; return ctxt (Failed { descr }) (* timestamp operations *) | Prim (loc, I_ADD, [], annot), 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 30384fea8..3f575cd32 100644 --- a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml @@ -294,6 +294,8 @@ and ('bef, 'aft) instr = ('rest, ('arg, 'ret) lambda * 'rest) instr | Fail : ('bef, 'aft) instr + | Failwith : + 'a ty -> ('a * 'rest, 'aft) instr | Nop : ('rest, 'rest) instr (* comparison *)