diff --git a/src/proto_alpha/lib_client/client_proto_fa12.ml b/src/proto_alpha/lib_client/client_proto_fa12.ml index db0ab1d3b280c788bf27e6e60a989eab11d3ff48..4644c3d044b7788c7f0b8d4a543970ac990276c5 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.ml +++ b/src/proto_alpha/lib_client/client_proto_fa12.ml @@ -754,8 +754,7 @@ let extract_error trace = TzTrace.fold (fun _ error -> match error with - | Environment.Ecoproto_error (Script_interpreter.Reject (loc, param, _)) - -> ( + | Environment.Ecoproto_error (Script_interpreter.Reject (loc, param)) -> ( match root param with | Prim (_, Script.D_Pair, [String (_, error); res], _) -> parse_error (error, res) 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 9510cf87059b4fbc19390cd75d98bddb5df3a545..2f0519f394c5174b3de266fc4d7c522174fc6d22 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -101,8 +101,8 @@ let collect_error_locations errs = | Invalid_syntactic_constant (loc, _, _) | Invalid_contract (loc, _) | Comparable_type_expected (loc, _) - | Overflow (loc, _) - | Reject (loc, _, _) + | Overflow loc + | Reject (loc, _) | Pair_bad_argument loc | Unpair_bad_argument loc | Dup_n_bad_argument loc ) @@ -755,38 +755,16 @@ let report_errors ~details ~show_source ?parsed ppf errs = tya print_ty tyb - | Reject (loc, v, trace) -> + | Reject (loc, v) -> Format.fprintf ppf - "%ascript reached FAILWITH instruction@ @[with@ %a@]%a" + "%ascript reached FAILWITH instruction@ @[with@ %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 - (fun ppf -> function - | None -> () - | Some trace -> - Format.fprintf - ppf - "@,@[trace@,%a@]" - print_execution_trace - trace) - trace + | Overflow loc -> + Format.fprintf ppf "%aunexpected arithmetic overflow" print_loc loc | err -> Format.fprintf ppf "%a" Environment.Error_monad.pp err) ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 9fdafa8e945343b3067d489bad498f3a88ada506..9a0a9366e895df581fcb6e25bd2ba7ef574713bb 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -102,9 +102,9 @@ type step_constants = Script_typed_ir.step_constants = { (* ---- Run-time errors -----------------------------------------------------*) -type error += Reject of Script.location * Script.expr * execution_trace option +type error += Reject of Script.location * Script.expr -type error += Overflow of Script.location * execution_trace option +type error += Overflow of Script.location type error += Runtime_contract_error of Contract.t @@ -118,25 +118,17 @@ type error += Michelson_too_many_recursive_calls let () = let open Data_encoding in - let trace_encoding = - list - @@ obj3 - (req "location" Script.location_encoding) - (req "gas" Gas.encoding) - (req "stack" (list Script.expr_encoding)) - in (* Reject *) register_error_kind `Temporary ~id:"michelson_v1.script_rejected" ~title:"Script failed" ~description:"A FAILWITH instruction was reached" - (obj3 + (obj2 (req "location" Script.location_encoding) - (req "with" Script.expr_encoding) - (opt "trace" trace_encoding)) - (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None) - (fun (loc, v, trace) -> Reject (loc, v, trace)) ; + (req "with" Script.expr_encoding)) + (function Reject (loc, v) -> Some (loc, v) | _ -> None) + (fun (loc, v) -> Reject (loc, v)) ; (* Overflow *) register_error_kind `Temporary @@ -144,11 +136,9 @@ let () = ~title:"Script failed (overflow error)" ~description: "A FAIL instruction was reached due to the detection of an overflow" - (obj2 - (req "location" Script.location_encoding) - (opt "trace" trace_encoding)) - (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None) - (fun (loc, trace) -> Overflow (loc, trace)) ; + (obj1 (req "location" Script.location_encoding)) + (function Overflow loc -> Some loc | _ -> None) + (fun loc -> Overflow loc) ; (* Runtime contract error *) register_error_kind `Temporary @@ -415,50 +405,6 @@ and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = - fun logger g gas (kinfo, k) ks accu stack -> - let x = accu in - let (y, stack) = stack in - match Script_int.to_int64 y with - | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) - | Some y -> - Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - -and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = - fun logger g gas (kinfo, k) ks accu stack -> - let y = accu in - let (x, stack) = stack in - match Script_int.to_int64 y with - | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) - | Some y -> - Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - -and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = - fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in - match Script_int.shift_left_n x y with - | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) - | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack - -and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = - fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in - match Script_int.shift_right_n x y with - | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) - | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack - -and ifailwith : ifailwith_type = - { - ifailwith = - (fun logger (ctxt, _) gas kloc tv accu -> - let v = accu in - let ctxt = update_context gas ctxt in - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) - >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); - } - and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> let arg = accu and (code, stack) = stack in @@ -771,10 +717,22 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let (y, stack) = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_teznat (kinfo, k) -> - imul_teznat None g gas (kinfo, k) ks accu stack - | IMul_nattez (kinfo, k) -> - imul_nattez None g gas (kinfo, k) ks accu stack + | IMul_teznat (kinfo, k) -> ( + let x = accu in + let (y, stack) = stack in + match Script_int.to_int64 y with + | None -> fail (Overflow kinfo.iloc) + | Some y -> + Tez.(x *? y) >>?= fun res -> + (step [@ocaml.tailcall]) g gas k ks res stack) + | IMul_nattez (kinfo, k) -> ( + let y = accu in + let (x, stack) = stack in + match Script_int.to_int64 y with + | None -> fail (Overflow kinfo.iloc) + | Some y -> + Tez.(x *? y) >>?= fun res -> + (step [@ocaml.tailcall]) g gas k ks res stack) (* boolean operations *) | IOr (_, k) -> let x = accu in @@ -870,8 +828,16 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let x = accu and (y, stack) = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (kinfo, k) -> ilsl_nat None g gas (kinfo, k) ks accu stack - | ILsr_nat (kinfo, k) -> ilsr_nat None g gas (kinfo, k) ks accu stack + | ILsl_nat (kinfo, k) -> ( + let x = accu and (y, stack) = stack in + match Script_int.shift_left_n x y with + | None -> fail (Overflow kinfo.iloc) + | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack) + | ILsr_nat (kinfo, k) -> ( + let x = accu and (y, stack) = stack in + match Script_int.shift_right_n x y with + | None -> fail (Overflow kinfo.iloc) + | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack) | IOr_nat (_, k) -> let x = accu and (y, stack) = stack in let res = Script_int.logor x y in @@ -931,8 +897,12 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | ILambda (_, lam, k) -> (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) | IFailwith (_, kloc, tv) -> - let {ifailwith} = ifailwith in - ifailwith None g gas kloc tv accu + let v = accu in + let ctxt = update_context gas ctxt in + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + fail (Reject (kloc, v)) (* comparison *) | ICompare (_, ty, k) -> let a = accu in @@ -1573,21 +1543,6 @@ and log : | ILoop_left (_, bl, br) -> let ks = with_log (KLoop_in_left (bl, KCons (br, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | IMul_teznat (kinfo, k) -> - let extra = (kinfo, k) in - (imul_teznat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | IMul_nattez (kinfo, k) -> - let extra = (kinfo, k) in - (imul_nattez [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | ILsl_nat (kinfo, k) -> - let extra = (kinfo, k) in - (ilsl_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | ILsr_nat (kinfo, k) -> - let extra = (kinfo, k) in - (ilsr_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | IFailwith (_, kloc, tv) -> - let {ifailwith} = ifailwith in - (ifailwith [@ocaml.tailcall]) (Some logger) g gas kloc tv accu | IExec (_, k) -> (iexec [@ocaml.tailcall]) (Some logger) g gas k ks accu stack | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index c57869e469d08e6599d3c2ef07e5b01f017f1dc2..e59285f43649929d30f02d7eecab28f8acee5d0a 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -36,9 +36,9 @@ open Alpha_context open Script_typed_ir -type error += Reject of Script.location * Script.expr * execution_trace option +type error += Reject of Script.location * Script.expr -type error += Overflow of Script.location * execution_trace option +type error += Overflow of Script.location type error += Runtime_contract_error of Contract.t diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 6a19b414337926ac63cf5122cb7805c5d6af885e..eee3a2191c894c770e48c9debdfc5a03d5b6ab7c 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -400,11 +400,6 @@ let log_exit logger ctxt gas kinfo_prev k accu stack = let log_control logger ks = logger.log_control ks -let get_log = function - | None -> Lwt.return (Ok None) - | Some logger -> logger.get_log () - [@@ocaml.inline always] - (* [log_kinstr logger i] emits an instruction to instrument the execution of [i] with [logger]. *) let log_kinstr logger i = ILog (kinfo_of_kinstr i, LogEntry, logger, i) @@ -857,61 +852,6 @@ type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) imap_iter_type = 'a * 'b -> ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t -type ('a, 'b, 'c, 'd, 'e, 'f) imul_teznat_type = - logger option -> - outdated_context * step_constants -> - local_gas_counter -> - (Tez.t, 'a) kinfo * (Tez.t, 'b, 'c, 'd) kinstr -> - ('c, 'd, 'e, 'f) continuation -> - Tez.t -> - Script_int.n Script_int.num * 'b -> - ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t - -type ('a, 'b, 'c, 'd, 'e, 'f) imul_nattez_type = - logger option -> - outdated_context * step_constants -> - local_gas_counter -> - (Script_int.n Script_int.num, 'a) kinfo * (Tez.t, 'b, 'c, 'd) kinstr -> - ('c, 'd, 'e, 'f) continuation -> - Script_int.n Script_int.num -> - Tez.t * 'b -> - ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t - -type ('a, 'b, 'c, 'd, 'e, 'f) ilsl_nat_type = - logger option -> - outdated_context * step_constants -> - local_gas_counter -> - (Script_int.n Script_int.num, 'a) kinfo - * (Script_int.n Script_int.num, 'b, 'c, 'd) kinstr -> - ('c, 'd, 'e, 'f) continuation -> - Script_int.n Script_int.num -> - Script_int.n Script_int.num * 'b -> - ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t - -type ('a, 'b, 'c, 'd, 'e, 'f) ilsr_nat_type = - logger option -> - outdated_context * step_constants -> - local_gas_counter -> - (Script_int.n Script_int.num, 'a) kinfo - * (Script_int.n Script_int.num, 'b, 'c, 'd) kinstr -> - ('c, 'd, 'e, 'f) continuation -> - Script_int.n Script_int.num -> - Script_int.n Script_int.num * 'b -> - ('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t - -type ifailwith_type = { - ifailwith : - 'a 'ac 'b. - logger option -> - outdated_context * step_constants -> - local_gas_counter -> - Script.location -> - ('a, 'ac) ty -> - 'a -> - ('b, error trace) result Lwt.t; -} -[@@unboxed] - type ('a, 'b, 'c, 'd, 'e, 'f, 'g) iexec_type = logger option -> outdated_context * step_constants -> diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml index 2736fa2f42acc0b3246cf7def7b3004ad776dac3..1a9d95ca67772be0ae5b469f672780094ca774bd 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml @@ -227,8 +227,8 @@ let error_encoding_tests = `Quick (test_json_roundtrip_err name e)) [ - ("Reject", Reject (0, script_expr_int, None)); - ("Overflow", Overflow (0, None)); + ("Reject", Reject (0, script_expr_int)); + ("Overflow", Overflow 0); ("Runtime_contract_error", Runtime_contract_error contract_zero); ("Bad_contract_parameter", Bad_contract_parameter contract_zero); ("Cannot_serialize_failure", Cannot_serialize_failure);