Michelson, Proto: show execution trace on failure also

When doing calling `trace code`, e.g. with option `--trace-stack` in
the client.

src/proto_alpha/lib_client/client_proto_programs.ml

@@ -73,21 +73,7 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed =
         print_expr storage
         (Format.pp_print_list Operation_result.pp_internal_operation) operations
         print_big_map_diff maybe_big_map_diff
-        (Format.pp_print_list
+        print_execution_trace trace >>= fun () ->
-           (fun ppf (loc, gas, stack) ->
-              Format.fprintf ppf
-                "- @[<v 0>location: %d (remaining gas: %a)@,\
-                 [ @[<v 0>%a ]@]@]"
-                loc Gas.pp gas
-                (Format.pp_print_list
-                   (fun ppf (e, annot) ->
-                      Format.fprintf ppf
-                        "@[<v 0>%a  \t%s@]"
-                        print_expr e
-                        (match annot with None -> "" | Some a -> a)
-                   ))
-                stack))
-        trace >>= fun () ->
       return ()
   | Error errs ->
       print_errors cctxt errs ~show_source ~parsed

src/proto_alpha/lib_client/michelson_v1_error_reporter.ml

@@ -90,8 +90,8 @@ let collect_error_locations errs =
         | Invalid_constant (loc, _, _)
         | Invalid_contract (loc, _)
         | Comparable_type_expected (loc, _)
-        | Overflow loc
+        | Overflow (loc, _)
-        | Reject loc) :: rest ->
+        | Reject (loc, _)) :: rest ->
         collect (loc :: acc) rest
     | _ :: rest -> collect acc rest in
   collect [] errs
@@ -431,12 +431,26 @@ 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 ->
+          | Reject (loc, trace) ->
-              Format.fprintf ppf "%ascript reached FAIL instruction"
+              Format.fprintf ppf
+                "%ascript reached FAIL instruction@ \
+                 %a"
                 print_loc loc
-          | Overflow loc ->
+                (fun ppf -> function
-              Format.fprintf ppf "%aunexpected arithmetic overflow"
+                   | 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
+                (fun ppf -> function
+                   | None -> ()
+                   | Some trace ->
+                       Format.fprintf ppf "@,@[<v 2>trace@,%a@]"
+                         print_execution_trace trace)
+                trace
           | err -> Format.fprintf ppf "%a" Alpha_environment.Error_monad.pp err
         end ;
         if rest <> [] then Format.fprintf ppf "@," ;

src/proto_alpha/lib_client/michelson_v1_printer.ml

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 open Proto_alpha
+open Alpha_context
 open Tezos_micheline
 open Micheline
 open Micheline_printer
@@ -43,6 +44,24 @@ let print_stack ppf = function
            print_annot_expr_unwrapped)
         more
 
+let print_execution_trace ppf trace =
+  Format.pp_print_list
+    (fun ppf (loc, gas, stack) ->
+       Format.fprintf ppf
+         "- @[<v 0>location: %d (remaining gas: %a)@,\
+          [ @[<v 0>%a ]@]@]"
+         loc Gas.pp gas
+         (Format.pp_print_list
+            (fun ppf (e, annot) ->
+               Format.fprintf ppf
+                 "@[<v 0>%a  \t%s@]"
+                 print_expr e
+                 (match annot with None -> "" | Some a -> a)
+            ))
+         stack)
+    ppf
+    trace
+
 let inject_types type_map parsed =
   let rec inject_expr = function
     | Seq (loc, items) ->

src/proto_alpha/lib_client/michelson_v1_printer.mli

@@ -17,6 +17,10 @@ val print_expr :
 val print_expr_unwrapped :
   Format.formatter -> Script_repr.expr -> unit
 
+val print_execution_trace:
+  Format.formatter ->
+  (Script.location * Gas.t * (Script.expr * string option) list) list -> unit
+
 (** Insert the type map returned by the typechecker as comments in a
     printable Micheline AST. *)
 val inject_types :

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -14,31 +14,47 @@ open Script_ir_translator
 
 (* ---- Run-time errors -----------------------------------------------------*)
 
-type error += Reject of Script.location
+type execution_trace =
-type error += Overflow of Script.location
+  (Script.location * Gas.t * (Script.expr * string option) list) list
+
+type error += Reject of Script.location * 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 *)
 
 let () =
   let open Data_encoding in
+  let trace_encoding =
+    (list @@ obj3
+       (req "location" Script.location_encoding)
+       (req "gas" Gas.encoding)
+       (req "stack"
+          (list
+             (obj2
+                (req "item" (Script.expr_encoding))
+                (opt "annot" string))))) in
   (* Reject *)
   register_error_kind
     `Temporary
     ~id:"scriptRejectedRuntimeError"
     ~title: "Script failed (runtime script error)"
     ~description: "A FAIL instruction was reached"
-    (obj1 (req "location" Script.location_encoding))
+    (obj2
-    (function Reject loc -> Some loc | _ -> None)
+       (req "location" Script.location_encoding)
-    (fun loc -> Reject loc);
+       (opt "trace" trace_encoding))
+    (function Reject (loc, trace) -> Some (loc, trace) | _ -> None)
+    (fun (loc, trace) -> Reject (loc, trace));
   (* Overflow *)
   register_error_kind
     `Temporary
     ~id:"scriptOverflowRuntimeError"
     ~title: "Script failed (overflow error)"
     ~description: "A FAIL instruction was reached due to the detection of an overflow"
-    (obj1 (req "location" Script.location_encoding))
+    (obj2
-    (function Overflow loc -> Some loc | _ -> None)
+       (req "location" Script.location_encoding)
-    (fun loc -> Overflow loc);
+       (opt "trace" trace_encoding))
+    (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)
+    (fun (loc, trace) -> Overflow (loc, trace));
   (* Runtime contract error *)
   register_error_kind
     `Temporary
@@ -93,9 +109,6 @@ let unparse_stack ctxt (stack, stack_ty) =
 
 module Interp_costs = Michelson_v1_gas.Cost_of
 
-type execution_trace =
-  (Script.location * Gas.t * (Script.expr * string option) list) list
-
 let rec interp
   : type p r.
     (?log: execution_trace ref ->
@@ -121,6 +134,8 @@ let rec interp
                 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) =
+          Option.map ~f:(!) log in
         let consume_gas_terop : type ret arg1 arg2 arg3 rest.
           (_ * (_ * (_ * rest)), ret * rest) descr ->
           ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) ->
@@ -364,7 +379,7 @@ let rec interp
             Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt ->
             begin
               match Script_int.to_int64 y with
-              | None -> fail (Overflow loc)
+              | None -> fail (Overflow (loc, get_log log))
               | Some y ->
                   Lwt.return Tez.(x *? y) >>=? fun res ->
                   logged_return (Item (res, rest), ctxt)
@@ -374,7 +389,7 @@ let rec interp
             Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt ->
             begin
               match Script_int.to_int64 y with
-              | None -> fail (Overflow loc)
+              | None -> fail (Overflow (loc, get_log log))
               | Some y ->
                   Lwt.return Tez.(x *? y) >>=? fun res ->
                   logged_return (Item (res, rest), ctxt)
@@ -471,14 +486,14 @@ let rec interp
             Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt ->
             begin
               match Script_int.shift_left_n x y with
-              | None -> fail (Overflow loc)
+              | None -> fail (Overflow (loc, get_log log))
               | Some x -> logged_return (Item (x, rest), ctxt)
             end
         | Lsr_nat, Item (x, Item (y, rest)) ->
             Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt ->
             begin
               match Script_int.shift_right_n x y with
-              | None -> fail (Overflow loc)
+              | None -> fail (Overflow (loc, get_log log))
               | Some r -> logged_return (Item (r, rest), ctxt)
             end
         | Or_nat, Item (x, Item (y, rest)) ->
@@ -528,7 +543,7 @@ let rec interp
             Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
             logged_return (Item (lam, rest), ctxt)
         | Fail, _ ->
-            fail (Reject loc)
+            fail (Reject (loc, get_log log))
         | Nop, stack ->
             logged_return (stack, ctxt)
         (* comparison *)

src/proto_alpha/lib_protocol/src/script_interpreter.mli

@@ -9,8 +9,11 @@
 
 open Alpha_context
 
-type error += Overflow of Script.location
+type execution_trace =
-type error += Reject of Script.location
+  (Script.location * Gas.t * (Script.expr * string option) list) list
+
+type error += Reject of Script.location * 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 *)
 
@@ -30,9 +33,6 @@ val execute:
   amount: Tez.t ->
   execution_result tzresult Lwt.t
 
-type execution_trace =
-  (Script.location * Gas.t * (Script.expr * string option) list) list
-
 val trace:
   Alpha_context.t ->
   Script_ir_translator.unparsing_mode ->