balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Michelson, Proto: show execution trace on failure also

Browse Source 
When doing calling `trace code`, e.g. with option `--trace-stack` in
the client.
This commit is contained in:
Alain Mebsout 2018-06-11 18:16:02 +02:00 committed by Benjamin Canou
parent eb5837943f
commit 1b67e538d8
6 changed files with 80 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/proto_alpha/lib_client/client_proto_programs.ml
View File

@ -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
"- @[<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 () ->
print_execution_trace trace >>= fun () ->
return ()
| Error errs ->
print_errors cctxt errs ~show_source ~parsed

26
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml
View File

@ -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 =
@[<hov 2>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 "@,@[<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 "@," ;

19
src/proto_alpha/lib_client/michelson_v1_printer.ml
View File

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

4
src/proto_alpha/lib_client/michelson_v1_printer.mli
View File

@ -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 :

47
src/proto_alpha/lib_protocol/src/script_interpreter.ml
View File

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

10
src/proto_alpha/lib_protocol/src/script_interpreter.mli
View File

@ -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 ->