diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 399a1a70b..516f043ad 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/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 - (fun ppf (loc, gas, stack) -> - Format.fprintf ppf - "- @[location: %d (remaining gas: %a)@,\ - [ @[%a ]@]@]" - loc Gas.pp gas - (Format.pp_print_list - (fun ppf (e, annot) -> - Format.fprintf ppf - "@[%a \t%s@]" - print_expr e - (match annot with None -> "" | Some a -> a) - )) - stack)) - trace >>= fun () -> + print_execution_trace trace >>= fun () -> return () | Error errs -> print_errors cctxt errs ~show_source ~parsed 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 be655fae6..218d94b89 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/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 - | Reject loc) :: rest -> + | Overflow (loc, _) + | 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 = @[is not compatible with type@ %a.@]@]" print_ty tya print_ty tyb - | Reject loc -> - Format.fprintf ppf "%ascript reached FAIL instruction" + | Reject (loc, trace) -> + Format.fprintf ppf + "%ascript reached FAIL instruction@ \ + %a" print_loc loc - | Overflow loc -> - Format.fprintf ppf "%aunexpected arithmetic overflow" + (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 + (fun ppf -> function + | None -> () + | Some trace -> + Format.fprintf ppf "@,@[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 "@," ; diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.ml b/src/proto_alpha/lib_client/michelson_v1_printer.ml index 2153e75f0..5091e2bf6 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.ml +++ b/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 + "- @[location: %d (remaining gas: %a)@,\ + [ @[%a ]@]@]" + loc Gas.pp gas + (Format.pp_print_list + (fun ppf (e, annot) -> + Format.fprintf ppf + "@[%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) -> diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.mli b/src/proto_alpha/lib_client/michelson_v1_printer.mli index 7aa3b2312..5bba9a7f1 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.mli +++ b/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 : diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index ef2309e60..97199d584 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/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 error += Overflow of Script.location +type execution_trace = + (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)) - (function Reject loc -> Some loc | _ -> None) - (fun loc -> Reject loc); + (obj2 + (req "location" Script.location_encoding) + (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)) - (function Overflow loc -> Some loc | _ -> None) - (fun loc -> Overflow loc); + (obj2 + (req "location" Script.location_encoding) + (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 *) diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli index 3aa5fdbb0..7fbf69a5c 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli @@ -9,8 +9,11 @@ open Alpha_context -type error += Overflow of Script.location -type error += Reject of Script.location +type execution_trace = + (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 ->