Michelson: instruction FAILWITH which takes one element on the stack

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;

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 =
                  @[<hov 2>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 "@,@[<v 2>trace@,%a@]"
                          print_execution_trace trace)
                 trace
+          | Reject (loc, Some v, trace) ->
+              Format.fprintf ppf
+                "%ascript reached FAILWITH instruction@ \
+                 @[<hov 2>with@ %a@]%a"
+                print_loc loc print_expr v
+                (fun ppf -> function
+                   | None -> ()
+                   | Some trace ->
+                       Format.fprintf ppf "@,@[<v 2>trace@,%a@]"
+                         print_execution_trace trace)
+                trace
           | Overflow (loc, trace) ->
               Format.fprintf ppf "%aunexpected arithmetic overflow%a"
                 print_loc loc

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

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) ;

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

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"
+    ~description: "A FAILWITH instruction was reached"
-    (obj2
+    (obj3
        (req "location" Script.location_encoding)
+       (opt "with" Script.expr_encoding)
        (opt "trace" trace_encoding))
-    (function Reject (loc, trace) -> Some (loc, trace) | _ -> None)
+    (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
-    (fun (loc, trace) -> Reject (loc, trace));
+    (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, None, get_log log))
-            fail (Reject (loc, 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 *)

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 *)

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
+      log_stack loc stack_ty aft ;
-        | None, _
-        | Some _, (Seq (-1, _) | Int _ | String _) -> ()
-        | Some log, (Prim _ | Seq _) ->
-            log loc (unparse_stack stack_ty) (unparse_stack aft)
-      end ;
       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),

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 *)