diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 41cb89700..7e614d10d 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -165,6 +165,16 @@ module Program = Client_aliases.Alias (struct let commands () = let open Cli_entries in + let show_types = ref false in + let show_types_arg = + "-details", + Arg.Set show_types, + "Show the types of each instruction" in + let trace_stack = ref false in + let trace_stack_arg = + "-trace-stack", + Arg.Set trace_stack, + "Show the stack after each step" in register_group "programs" "Commands for managing the record of known programs" ; [ command @@ -201,6 +211,7 @@ let commands () = command ~group: "programs" ~desc: "ask the node to run a program" + ~args: [ trace_stack_arg ] (prefixes [ "run" ; "program" ] @@ Program.source_param @@ prefixes [ "on" ; "storage" ] @@ -210,18 +221,38 @@ let commands () = @@ stop) (fun program storage input () -> let open Data_encoding in - Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function - | Ok (storage, output) -> - Format.printf "@[@[storage@,%a@]@,@[output@,%a@]@]@." - (print_ir (fun l -> false)) storage - (print_ir (fun l -> false)) output ; - Lwt.return () - | Error errs -> - pp_print_error Format.err_formatter errs ; - error "error running program") ; + if !trace_stack then + Client_proto_rpcs.Helpers.trace_code (block ()) program (storage, input) >>= function + | Ok (storage, output, trace) -> + Format.printf "@[@[storage@,%a@]@,@[output@,%a@]@,@[trace@,%a@]@]@." + (print_ir (fun _ -> false)) storage + (print_ir (fun _ -> false)) output + (Format.pp_print_list + (fun ppf (loc, gas, stack) -> + Format.fprintf ppf + "- @[location: %d (remaining gas: %d)@,[ @[%a ]@]@]" + loc gas + (Format.pp_print_list (print_ir (fun _ -> false))) + stack)) + trace ; + Lwt.return () + | Error errs -> + pp_print_error Format.err_formatter errs ; + error "error running program" + else + Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function + | Ok (storage, output) -> + Format.printf "@[@[storage@,%a@]@,@[output@,%a@]@]@." + (print_ir (fun _ -> false)) storage + (print_ir (fun _ -> false)) output ; + Lwt.return () + | Error errs -> + pp_print_error Format.err_formatter errs ; + error "error running program") ; command ~group: "programs" ~desc: "ask the node to typecheck a program" + ~args: [ show_types_arg ] (prefixes [ "typecheck" ; "program" ] @@ Program.source_param @@ stop) @@ -231,20 +262,22 @@ let commands () = | Ok type_map -> let type_map, program = unexpand_macros type_map program in message "Well typed" ; - print_program - (fun l -> List.mem_assoc l type_map) - Format.std_formatter program ; - Format.printf "@." ; - List.iter - (fun (loc, (before, after)) -> - Format.printf - "%3d@[ : [ @[%a ]@]@,-> [ @[%a ]@]@]@." - loc - (Format.pp_print_list (print_ir (fun _ -> false))) - before - (Format.pp_print_list (print_ir (fun _ -> false))) - after) - type_map ; + if !show_types then begin + print_program + (fun l -> List.mem_assoc l type_map) + Format.std_formatter program ; + Format.printf "@." ; + List.iter + (fun (loc, (before, after)) -> + Format.printf + "%3d@[ : [ @[%a ]@]@,-> [ @[%a ]@]@]@." + loc + (Format.pp_print_list (print_ir (fun _ -> false))) + before + (Format.pp_print_list (print_ir (fun _ -> false))) + after) + (List.sort compare type_map) + end ; Lwt.return () | Error errs -> pp_print_error Format.err_formatter errs ; diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.ml b/src/client/embedded/bootstrap/client_proto_rpcs.ml index c6c42c93f..ee474b1fc 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.ml +++ b/src/client/embedded/bootstrap/client_proto_rpcs.ml @@ -131,6 +131,10 @@ module Helpers = struct call_error_service1 Services.Helpers.run_code block (code, storage, input, None, None) + let trace_code block code (storage, input) = + call_error_service1 Services.Helpers.trace_code + block (code, storage, input, None, None) + let typecheck_tagged_data = call_error_service1 Services.Helpers.typecheck_tagged_data let typecheck_untagged_data = call_error_service1 Services.Helpers.typecheck_untagged_data diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.mli b/src/client/embedded/bootstrap/client_proto_rpcs.mli index f0932ac12..307e8f386 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.mli +++ b/src/client/embedded/bootstrap/client_proto_rpcs.mli @@ -95,6 +95,10 @@ module Helpers : sig val run_code: block -> Script.code -> (Script.expr * Script.expr) -> (Script.expr * Script.expr) tzresult Lwt.t + val trace_code: block -> Script.code -> + (Script.expr * Script.expr) -> + (Script.expr * Script.expr * + (Script.location * int * Script.expr list) list) tzresult Lwt.t val typecheck_code: block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t val typecheck_tagged_data: block -> Script.expr -> unit tzresult Lwt.t val typecheck_untagged_data: block -> Script.expr * Script.expr -> unit tzresult Lwt.t diff --git a/src/proto/bootstrap/script_interpreter.ml b/src/proto/bootstrap/script_interpreter.ml index 5e2163527..94f05e6cf 100644 --- a/src/proto/bootstrap/script_interpreter.ml +++ b/src/proto/bootstrap/script_interpreter.ml @@ -65,229 +65,246 @@ type 'tys stack = | Item : 'ty * 'rest stack -> ('ty * 'rest) stack | Empty : end_of_stack stack +let rec unparse_stack + : type a. a stack * a stack_ty -> Script.expr list + = function + | Empty, Empty_t -> [] + | Item (v, rest), Item_t (ty, rest_ty) -> + unparse_tagged_data ty v :: unparse_stack (rest, rest_ty) + let rec interp : type p r. + ?log: (Script.location * int * Script.expr list) list ref -> int -> Contract.t -> Contract.t -> Tez.t -> context -> (p, r) lambda -> p -> (r * int * context) tzresult Lwt.t - = fun qta orig source amount ctxt (Lam (code, _)) arg -> + = fun ?log qta orig source amount ctxt (Lam (code, _)) arg -> let rec step : type b a. - int -> context -> (b, a) instr -> b stack -> + int -> context -> (b, a) descr -> b stack -> (a stack * int * context) tzresult Lwt.t = - fun qta ctxt instr stack -> + fun qta ctxt ({ instr ; loc } as descr) stack -> if Compare.Int.(qta <= 0) then fail Quota_exceeded - else match instr, stack with + else + let logged_return ((ret, qta, _) as res) = + match log with + | None -> return res + | Some log -> + log := (descr.loc, qta, unparse_stack (ret, descr.aft)) :: !log ; + return res in + match instr, stack with (* stack ops *) | Drop, Item (_, rest) -> - return (rest, qta - 1, ctxt) + logged_return (rest, qta - 1, ctxt) | Dup, Item (v, rest) -> - return (Item (v, Item (v, rest)), qta - 1, ctxt) + logged_return (Item (v, Item (v, rest)), qta - 1, ctxt) | Swap, Item (vi, Item (vo, rest)) -> - return (Item (vo, Item (vi, rest)), qta - 1, ctxt) + logged_return (Item (vo, Item (vi, rest)), qta - 1, ctxt) | Const v, rest -> - return (Item (v, rest), qta - 1, ctxt) + logged_return (Item (v, rest), qta - 1, ctxt) (* options *) | Cons_some, Item (v, rest) -> - return (Item (Some v, rest), qta - 1, ctxt) + logged_return (Item (Some v, rest), qta - 1, ctxt) | Cons_none _, rest -> - return (Item (None, rest), qta - 1, ctxt) + logged_return (Item (None, rest), qta - 1, ctxt) | If_none (bt, _), Item (None, rest) -> step qta ctxt bt rest | If_none (_, bf), Item (Some v, rest) -> step qta ctxt bf (Item (v, rest)) (* pairs *) | Cons_pair, Item (a, Item (b, rest)) -> - return (Item ((a, b), rest), qta - 1, ctxt) + logged_return (Item ((a, b), rest), qta - 1, ctxt) | Car, Item ((a, _), rest) -> - return (Item (a, rest), qta - 1, ctxt) + logged_return (Item (a, rest), qta - 1, ctxt) | Cdr, Item ((_, b), rest) -> - return (Item (b, rest), qta - 1, ctxt) + logged_return (Item (b, rest), qta - 1, ctxt) (* unions *) | Left, Item (v, rest) -> - return (Item (L v, rest), qta - 1, ctxt) + logged_return (Item (L v, rest), qta - 1, ctxt) | Right, Item (v, rest) -> - return (Item (R v, rest), qta - 1, ctxt) + logged_return (Item (R v, rest), qta - 1, ctxt) | If_left (bt, _), Item (L v, rest) -> step qta ctxt bt (Item (v, rest)) | If_left (_, bf), Item (R v, rest) -> step qta ctxt bf (Item (v, rest)) (* lists *) | Cons_list, Item (hd, Item (tl, rest)) -> - return (Item (hd :: tl, rest), qta - 1, ctxt) + logged_return (Item (hd :: tl, rest), qta - 1, ctxt) | Nil, rest -> - return (Item ([], rest), qta - 1, ctxt) + logged_return (Item ([], rest), qta - 1, ctxt) | If_cons (_, bf), Item ([], rest) -> step qta ctxt bf rest | If_cons (bt, _), Item (hd :: tl, rest) -> step qta ctxt bt (Item (hd, Item (tl, rest))) | List_map, Item (lam, Item (l, rest)) -> fold_left_s (fun (tail, qta, ctxt) arg -> - interp qta orig source amount ctxt lam arg + interp ?log qta orig source amount ctxt lam arg >>=? fun (ret, qta, ctxt) -> return (ret :: tail, qta, ctxt)) ([], qta, ctxt) l >>=? fun (res, qta, ctxt) -> - return (Item (res, rest), qta, ctxt) + logged_return (Item (res, rest), qta, ctxt) | List_reduce, Item (lam, Item (l, Item (init, rest))) -> fold_left_s (fun (partial, qta, ctxt) arg -> - interp qta orig source amount ctxt lam (arg, partial) + interp ?log qta orig source amount ctxt lam (arg, partial) >>=? fun (partial, qta, ctxt) -> return (partial, qta, ctxt)) (init, qta, ctxt) l >>=? fun (res, qta, ctxt) -> - return (Item (res, rest), qta, ctxt) + logged_return (Item (res, rest), qta, ctxt) (* sets *) | Empty_set t, rest -> - return (Item (empty_set t, rest), qta - 1, ctxt) + logged_return (Item (empty_set t, rest), qta - 1, ctxt) | Set_map t, Item (lam, Item (set, rest)) -> let items = List.rev (set_fold (fun e acc -> e :: acc) set []) in fold_left_s (fun (res, qta, ctxt) arg -> - interp qta orig source amount ctxt lam arg >>=? + interp ?log qta orig source amount ctxt lam arg >>=? fun (ret, qta, ctxt) -> return (set_update ret true res, qta, ctxt)) (empty_set t, qta, ctxt) items >>=? fun (res, qta, ctxt) -> - return (Item (res, rest), qta, ctxt) + logged_return (Item (res, rest), qta, ctxt) | Set_reduce, Item (lam, Item (set, Item (init, rest))) -> let items = List.rev (set_fold (fun e acc -> e :: acc) set []) in fold_left_s (fun (partial, qta, ctxt) arg -> - interp qta orig source amount ctxt lam (arg, partial) + interp ?log qta orig source amount ctxt lam (arg, partial) >>=? fun (partial, qta, ctxt) -> return (partial, qta, ctxt)) (init, qta, ctxt) items >>=? fun (res, qta, ctxt) -> - return (Item (res, rest), qta, ctxt) + logged_return (Item (res, rest), qta, ctxt) | Set_mem, Item (v, Item (set, rest)) -> - return (Item (set_mem v set, rest), qta - 1, ctxt) + logged_return (Item (set_mem v set, rest), qta - 1, ctxt) | Set_update, Item (v, Item (presence, Item (set, rest))) -> - return (Item (set_update v presence set, rest), qta - 1, ctxt) + logged_return (Item (set_update v presence set, rest), qta - 1, ctxt) (* maps *) | Empty_map (t, _), rest -> - return (Item (empty_map t, rest), qta - 1, ctxt) + logged_return (Item (empty_map t, rest), qta - 1, ctxt) | Map_map, Item (lam, Item (map, rest)) -> let items = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in fold_left_s (fun (acc, qta, ctxt) (k, v) -> - interp qta orig source amount ctxt lam (k, v) + interp ?log qta orig source amount ctxt lam (k, v) >>=? fun (ret, qta, ctxt) -> return (map_update k (Some ret) acc, qta, ctxt)) (empty_map (map_key_ty map), qta, ctxt) items >>=? fun (res, qta, ctxt) -> - return (Item (res, rest), qta, ctxt) + logged_return (Item (res, rest), qta, ctxt) | Map_reduce, Item (lam, Item (map, Item (init, rest))) -> let items = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in fold_left_s (fun (partial, qta, ctxt) arg -> - interp qta orig source amount ctxt lam (arg, partial) + interp ?log qta orig source amount ctxt lam (arg, partial) >>=? fun (partial, qta, ctxt) -> return (partial, qta, ctxt)) (init, qta, ctxt) items >>=? fun (res, qta, ctxt) -> - return (Item (res, rest), qta, ctxt) + logged_return (Item (res, rest), qta, ctxt) | Map_mem, Item (v, Item (map, rest)) -> - return (Item (map_mem v map, rest), qta - 1, ctxt) + logged_return (Item (map_mem v map, rest), qta - 1, ctxt) | Map_get, Item (v, Item (map, rest)) -> - return (Item (map_get v map, rest), qta - 1, ctxt) + logged_return (Item (map_get v map, rest), qta - 1, ctxt) | Map_update, Item (k, Item (v, Item (map, rest))) -> - return (Item (map_update k v map, rest), qta - 1, ctxt) + logged_return (Item (map_update k v map, rest), qta - 1, ctxt) (* timestamp operations *) - | Add_seconds_to_timestamp (kind, _pos), Item (n, Item (t, rest)) -> + | Add_seconds_to_timestamp kind, Item (n, Item (t, rest)) -> let n = Script_int.to_int64 kind n in Lwt.return (Period.of_seconds n >>? fun p -> Timestamp.(t +? p) >>? fun res -> - Ok (Item (res, rest), qta - 1, ctxt)) - | Add_timestamp_to_seconds (kind, _pos), Item (t, Item (n, rest)) -> + Ok (Item (res, rest), qta - 1, ctxt)) >>=? fun res -> + logged_return res + | Add_timestamp_to_seconds kind, Item (t, Item (n, rest)) -> let n = Script_int.to_int64 kind n in Lwt.return (Period.of_seconds n >>? fun p -> Timestamp.(t +? p) >>? fun res -> - Ok (Item (res, rest), qta - 1, ctxt)) + Ok (Item (res, rest), qta - 1, ctxt)) >>=? fun res -> + logged_return res (* string operations *) | Concat, Item (x, Item (y, rest)) -> - return (Item (x ^ y, rest), qta - 1, ctxt) + logged_return (Item (x ^ y, rest), qta - 1, ctxt) (* currency operations *) | Add_tez, Item (x, Item (y, rest)) -> Lwt.return Tez.(x +? y) >>=? fun res -> - return (Item (res, rest), qta - 1, ctxt) + logged_return (Item (res, rest), qta - 1, ctxt) | Sub_tez, Item (x, Item (y, rest)) -> Lwt.return Tez.(x -? y) >>=? fun res -> - return (Item (res, rest), qta - 1, ctxt) + logged_return (Item (res, rest), qta - 1, ctxt) | Mul_tez kind, Item (x, Item (y, rest)) -> Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res -> - return (Item (res, rest), qta - 1, ctxt) + logged_return (Item (res, rest), qta - 1, ctxt) | Mul_tez' kind, Item (y, Item (x, rest)) -> Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res -> - return (Item (res, rest), qta - 1, ctxt) + logged_return (Item (res, rest), qta - 1, ctxt) (* boolean operations *) | Or, Item (x, Item (y, rest)) -> - return (Item (x || y, rest), qta - 1, ctxt) + logged_return (Item (x || y, rest), qta - 1, ctxt) | And, Item (x, Item (y, rest)) -> - return (Item (x && y, rest), qta - 1, ctxt) + logged_return (Item (x && y, rest), qta - 1, ctxt) | Xor, Item (x, Item (y, rest)) -> - return (Item (not x && y || x && not y, rest), qta - 1, ctxt) + logged_return (Item (not x && y || x && not y, rest), qta - 1, ctxt) | Not, Item (x, rest) -> - return (Item (not x, rest), qta - 1, ctxt) + logged_return (Item (not x, rest), qta - 1, ctxt) (* integer operations *) - | Checked_abs_int (kind, pos), Item (x, rest) -> + | Checked_abs_int kind, Item (x, rest) -> begin match Script_int.checked_abs kind x with - | None -> fail (Overflow pos) - | Some res -> return (Item (res, rest), qta - 1, ctxt) + | None -> fail (Overflow loc) + | Some res -> logged_return (Item (res, rest), qta - 1, ctxt) end - | Checked_neg_int (kind, pos), Item (x, rest) -> + | Checked_neg_int kind, Item (x, rest) -> begin match Script_int.checked_neg kind x with - | None -> fail (Overflow pos) - | Some res -> return (Item (res, rest), qta - 1, ctxt) + | None -> fail (Overflow loc) + | Some res -> logged_return (Item (res, rest), qta - 1, ctxt) end - | Checked_add_int (kind, pos), Item (x, Item (y, rest)) -> + | Checked_add_int kind, Item (x, Item (y, rest)) -> begin match Script_int.checked_add kind x y with - | None -> fail (Overflow pos) - | Some res -> return (Item (res, rest), qta - 1, ctxt) + | None -> fail (Overflow loc) + | Some res -> logged_return (Item (res, rest), qta - 1, ctxt) end - | Checked_sub_int (kind, pos), Item (x, Item (y, rest)) -> + | Checked_sub_int kind, Item (x, Item (y, rest)) -> begin match Script_int.checked_sub kind x y with - | None -> fail (Overflow pos) - | Some res -> return (Item (res, rest), qta - 1, ctxt) + | None -> fail (Overflow loc) + | Some res -> logged_return (Item (res, rest), qta - 1, ctxt) end - | Checked_mul_int (kind, pos), Item (x, Item (y, rest)) -> + | Checked_mul_int kind, Item (x, Item (y, rest)) -> begin match Script_int.checked_mul kind x y with - | None -> fail (Overflow pos) - | Some res -> return (Item (res, rest), qta - 1, ctxt) + | None -> fail (Overflow loc) + | Some res -> logged_return (Item (res, rest), qta - 1, ctxt) end | Abs_int kind, Item (x, rest) -> - return (Item (Script_int.abs kind x, rest), qta - 1, ctxt) + logged_return (Item (Script_int.abs kind x, rest), qta - 1, ctxt) | Neg_int kind, Item (x, rest) -> - return (Item (Script_int.neg kind x, rest), qta - 1, ctxt) + logged_return (Item (Script_int.neg kind x, rest), qta - 1, ctxt) | Add_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.add kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.add kind x y, rest), qta - 1, ctxt) | Sub_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.sub kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.sub kind x y, rest), qta - 1, ctxt) | Mul_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt) - | Div_int (kind, pos), Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.mul kind x y, rest), qta - 1, ctxt) + | Div_int kind, Item (x, Item (y, rest)) -> if Compare.Int64.(Script_int.to_int64 kind y = 0L) then - fail (Division_by_zero pos) + fail (Division_by_zero loc) else - return (Item (Script_int.div kind x y, rest), qta - 1, ctxt) - | Mod_int (kind, pos), Item (x, Item (y, rest)) -> + logged_return (Item (Script_int.div kind x y, rest), qta - 1, ctxt) + | Mod_int kind, Item (x, Item (y, rest)) -> if Compare.Int64.(Script_int.to_int64 kind y = 0L) then - fail (Division_by_zero pos) + fail (Division_by_zero loc) else - return (Item (Script_int.rem kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.rem kind x y, rest), qta - 1, ctxt) | Lsl_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.logsl kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.logsl kind x y, rest), qta - 1, ctxt) | Lsr_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.logsr kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.logsr kind x y, rest), qta - 1, ctxt) | Or_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.logor kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.logor kind x y, rest), qta - 1, ctxt) | And_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.logand kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.logand kind x y, rest), qta - 1, ctxt) | Xor_int kind, Item (x, Item (y, rest)) -> - return (Item (Script_int.logxor kind x y, rest), qta - 1, ctxt) + logged_return (Item (Script_int.logxor kind x y, rest), qta - 1, ctxt) | Not_int kind, Item (x, rest) -> - return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt) + logged_return (Item (Script_int.lognot kind x, rest), qta - 1, ctxt) (* control *) | Seq (hd, tl), stack -> step qta ctxt hd stack >>=? fun (trans, qta, ctxt) -> @@ -298,83 +315,83 @@ let rec interp step qta ctxt bf rest | Loop body, Item (true, rest) -> step qta ctxt body rest >>=? fun (trans, qta, ctxt) -> - step (qta - 1) ctxt (Loop body) trans + step (qta - 1) ctxt descr trans | Loop _, Item (false, rest) -> - return (rest, qta, ctxt) + logged_return (rest, qta, ctxt) | Dip b, Item (ign, rest) -> step qta ctxt b rest >>=? fun (res, qta, ctxt) -> - return (Item (ign, res), qta, ctxt) + logged_return (Item (ign, res), qta, ctxt) | Exec, Item (arg, Item (lam, rest)) -> - interp qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt) -> - return (Item (res, rest), qta - 1, ctxt) + interp ?log qta orig source amount ctxt lam arg >>=? fun (res, qta, ctxt) -> + logged_return (Item (res, rest), qta - 1, ctxt) | Lambda lam, rest -> - return (Item (lam, rest), qta - 1, ctxt) - | Fail pos, _ -> - fail (Reject pos) + logged_return (Item (lam, rest), qta - 1, ctxt) + | Fail, _ -> + fail (Reject loc) | Nop, stack -> - return (stack, qta - 1, ctxt) + logged_return (stack, qta - 1, ctxt) (* comparison *) | Compare Bool_key, Item (a, Item (b, rest)) -> let cmpres = Compare.Bool.compare a b in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Compare String_key, Item (a, Item (b, rest)) -> let cmpres = Compare.String.compare a b in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Compare Tez_key, Item (a, Item (b, rest)) -> let cmpres = Tez.compare a b in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Compare (Int_key kind), Item (a, Item (b, rest)) -> let cmpres = Script_int.compare kind a b in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Compare Key_key, Item (a, Item (b, rest)) -> let cmpres = Ed25519.Public_key_hash.compare a b in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Compare Timestamp_key, Item (a, Item (b, rest)) -> let cmpres = Timestamp.compare a b in let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) (* comparators *) | Eq, Item (cmpres, rest) -> let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Compare.Int64.(cmpres = 0L) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Neq, Item (cmpres, rest) -> let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Compare.Int64.(cmpres <> 0L) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Lt, Item (cmpres, rest) -> let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Compare.Int64.(cmpres < 0L) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Gt, Item (cmpres, rest) -> let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Compare.Int64.(cmpres > 0L) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Le, Item (cmpres, rest) -> let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Compare.Int64.(cmpres <= 0L) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) | Ge, Item (cmpres, rest) -> let cmpres = Script_int.to_int64 Int64 cmpres in let cmpres = Compare.Int64.(cmpres >= 0L) in - return (Item (cmpres, rest), qta - 1, ctxt) + logged_return (Item (cmpres, rest), qta - 1, ctxt) (* casts *) - | Checked_int_of_int (_, kt, pos), Item (v, rest) -> + | Checked_int_of_int (_, kt), Item (v, rest) -> begin match Script_int.checked_cast kt v with - | None -> fail (Overflow pos) - | Some res -> return (Item (res, rest), qta - 1, ctxt) + | None -> fail (Overflow loc) + | Some res -> logged_return (Item (res, rest), qta - 1, ctxt) end | Int_of_int (_, kt), Item (v, rest) -> - return (Item (Script_int.cast kt v, rest), qta - 1, ctxt) + logged_return (Item (Script_int.cast kt v, rest), qta - 1, ctxt) (* protocol *) | Manager, Item ((_, _, contract), rest) -> Contract.get_manager ctxt contract >>=? fun manager -> - return (Item (manager, rest), qta - 1, ctxt) - | Transfer_tokens (storage_type, loc), + logged_return (Item (manager, rest), qta - 1, ctxt) + | Transfer_tokens storage_type, Item (p, Item (amount, Item ((tp, Void_t, destination), Item (sto, Empty)))) -> begin Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> @@ -402,39 +419,39 @@ let rec interp | No_script -> assert false | Script { storage = { storage } } -> parse_untagged_data ctxt storage_type storage >>=? fun sto -> - return (Item ((), Item (sto, Empty)), qta - 1, ctxt)) - end - | Transfer_tokens (storage_type, loc), - Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin - Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> - Contract.credit ctxt destination amount >>=? fun ctxt -> - Contract.get_script ctxt destination >>=? function - | No_script -> fail (Invalid_contract (loc, destination)) - | Script { code ; storage } -> - let sto = unparse_untagged_data storage_type sto in - Contract.update_script_storage ctxt source sto >>=? fun ctxt -> - let p = unparse_untagged_data tp p in - execute source destination ctxt storage code amount p qta - >>=? fun (sto, ret, qta, ctxt) -> - Contract.update_script_storage - ctxt destination sto >>=? fun ctxt -> - trace - (Invalid_contract (loc, destination)) - (parse_untagged_data ctxt tr ret) >>=? fun v -> - Contract.get_script ctxt source >>=? (function - | No_script -> assert false - | Script { storage = { storage } } -> - parse_untagged_data ctxt storage_type storage >>=? fun sto -> - return (Item (v, Item (sto, Empty)), qta - 1, ctxt)) - end - | Create_account, - Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> + logged_return (Item ((), Item (sto, Empty)), qta - 1, ctxt)) + end + | Transfer_tokens storage_type, + Item (p, Item (amount, Item ((tp, tr, destination), Item (sto, Empty)))) -> begin + Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> + Contract.credit ctxt destination amount >>=? fun ctxt -> + Contract.get_script ctxt destination >>=? function + | No_script -> fail (Invalid_contract (loc, destination)) + | Script { code ; storage } -> + let sto = unparse_untagged_data storage_type sto in + Contract.update_script_storage ctxt source sto >>=? fun ctxt -> + let p = unparse_untagged_data tp p in + execute source destination ctxt storage code amount p qta + >>=? fun (sto, ret, qta, ctxt) -> + Contract.update_script_storage + ctxt destination sto >>=? fun ctxt -> + trace + (Invalid_contract (loc, destination)) + (parse_untagged_data ctxt tr ret) >>=? fun v -> + Contract.get_script ctxt source >>=? (function + | No_script -> assert false + | Script { storage = { storage } } -> + parse_untagged_data ctxt storage_type storage >>=? fun sto -> + logged_return (Item (v, Item (sto, Empty)), qta - 1, ctxt)) + end + | Create_account, + Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> Contract.unconditional_spend ctxt source credit >>=? fun ctxt -> Lwt.return Tez.(credit -? Constants.origination_burn) >>=? fun balance -> Contract.originate ctxt ~manager ~delegate ~balance ~script:No_script ~spendable:true ~delegatable >>=? fun (ctxt, contract) -> - return (Item ((Void_t, Void_t, contract), rest), qta - 1, ctxt) + logged_return (Item ((Void_t, Void_t, contract), rest), qta - 1, ctxt) | Create_contract (g, p, r), Item (manager, Item (delegate, Item (delegatable, Item (credit, Item (Lam (_, code), Item (init, rest)))))) -> @@ -454,35 +471,43 @@ let rec interp ~manager ~delegate ~balance ~script:(Script { code ; storage }) ~spendable:true ~delegatable >>=? fun (ctxt, contract) -> - return (Item ((p, r, contract), rest), qta - 1, ctxt) + logged_return (Item ((p, r, contract), rest), qta - 1, ctxt) | Balance, rest -> Contract.get_balance ctxt source >>=? fun balance -> - return (Item (balance, rest), qta - 1, ctxt) + logged_return (Item (balance, rest), qta - 1, ctxt) | Now, rest -> Timestamp.get_current ctxt >>=? fun now -> - return (Item (now, rest), qta - 1, ctxt) + logged_return (Item (now, rest), qta - 1, ctxt) | Check_signature, Item (key, Item ((signature, message), rest)) -> Public_key.get ctxt key >>=? fun key -> let message = MBytes.of_string message in let res = Ed25519.check_signature key signature message in - return (Item (res, rest), qta - 1, ctxt) + logged_return (Item (res, rest), qta - 1, ctxt) | H ty, Item (v, rest) -> let hash = Script.hash_expr (unparse_untagged_data ty v) in - return (Item (hash, rest), qta - 1, ctxt) + logged_return (Item (hash, rest), qta - 1, ctxt) | Steps_to_quota, rest -> let steps = Script_int.of_int64 Uint32 (Int64.of_int qta) in - return (Item (steps, rest), qta - 1, ctxt) + logged_return (Item (steps, rest), qta - 1, ctxt) | Source (ta, tb), rest -> - return (Item ((ta, tb, orig), rest), qta - 1, ctxt) + logged_return (Item ((ta, tb, orig), rest), qta - 1, ctxt) | Amount, rest -> - return (Item (amount, rest), qta - 1, ctxt) + logged_return (Item (amount, rest), qta - 1, ctxt) in - step qta ctxt code (Item (arg, Empty)) >>=? fun (Item (ret, Empty), qta, ctxt) -> + let stack = (Item (arg, Empty)) in + begin match log with + | None -> () + | Some log -> + log := (code.loc, qta, unparse_stack (stack, code.bef)) :: !log + end ; + step qta ctxt code stack >>=? fun (Item (ret, Empty), qta, ctxt) -> return (ret, qta, ctxt) (* ---- contract handling ---------------------------------------------------*) -and execute orig source ctxt { storage; storage_type } { code; arg_type; ret_type } amount arg qta = +and execute ?log orig source ctxt storage script amount arg qta = + let { Script.storage ; storage_type } = storage in + let { Script.code ; arg_type ; ret_type } = script in parse_ty arg_type >>=? fun (Ex arg_type) -> parse_ty ret_type >>=? fun (Ex ret_type) -> parse_ty storage_type >>=? fun (Ex storage_type) -> @@ -491,8 +516,17 @@ and execute orig source ctxt { storage; storage_type } { code; arg_type; ret_typ parse_lambda ctxt arg_type_full ret_type_full code >>=? fun lambda -> parse_untagged_data ctxt arg_type arg >>=? fun arg -> parse_untagged_data ctxt storage_type storage >>=? fun storage -> - interp qta orig source amount ctxt lambda ((amount, arg), storage) >>=? fun (ret, qta, ctxt) -> - let ret, storage = ret in - return (unparse_untagged_data storage_type storage, - unparse_untagged_data ret_type ret, - qta, ctxt) + interp ?log qta orig source amount ctxt lambda ((amount, arg), storage) + >>=? fun (ret, qta, ctxt) -> + let ret, storage = ret in + return (unparse_untagged_data storage_type storage, + unparse_untagged_data ret_type ret, + qta, ctxt) + +let trace orig source ctxt storage script amount arg qta = + let log = ref [] in + execute ~log orig source ctxt storage script amount arg qta >>=? fun res -> + return (res, List.rev !log) + +let execute orig source ctxt storage script amount arg qta = + execute orig source ctxt storage script amount arg qta diff --git a/src/proto/bootstrap/script_interpreter.mli b/src/proto/bootstrap/script_interpreter.mli index 9a32c7987..3fbae676f 100644 --- a/src/proto/bootstrap/script_interpreter.mli +++ b/src/proto/bootstrap/script_interpreter.mli @@ -21,3 +21,9 @@ val execute: Contract.t -> Contract.t -> Tezos_context.t -> Script.storage -> Script.code -> Tez.t -> Script.expr -> int -> (Script.expr * Script.expr * int * context) tzresult Lwt.t + +val trace: Contract.t -> Contract.t -> Tezos_context.t -> + Script.storage -> Script.code -> Tez.t -> + Script.expr -> int -> + ((Script.expr * Script.expr * int * context) * + (Script.location * int * Script.expr list) list) tzresult Lwt.t diff --git a/src/proto/bootstrap/script_ir_translator.ml b/src/proto/bootstrap/script_ir_translator.ml index 17753a525..285c14005 100644 --- a/src/proto/bootstrap/script_ir_translator.ml +++ b/src/proto/bootstrap/script_ir_translator.ml @@ -14,10 +14,6 @@ open Script_typed_ir (* ---- Error reporting -----------------------------------------------------*) -type 'ty stack_ty = - | Item_t : 'ty ty * 'rest stack_ty -> ('ty * 'rest) stack_ty - | Empty_t : end_of_stack stack_ty - (* Boxed existentials types to put in exception constructors *) type stack_ty_val = Stack_ty : _ stack_ty -> stack_ty_val type ty_val = @@ -282,13 +278,13 @@ let map_fold (* ---- Type checker resuls -------------------------------------------------*) type 'bef judgement = - | Typed : ('bef, 'aft) instr * 'aft stack_ty -> 'bef judgement - | Failed : { instr : 'aft. 'aft stack_ty -> ('bef, 'aft) instr } -> 'bef judgement + | Typed : ('bef, 'aft) descr -> 'bef judgement + | Failed : { descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr } -> 'bef judgement (* ---- type checker --------------------------------------------------------*) type ('t, 'f, 'b) branch = - { branch : 'r. ('t, 'r) instr -> ('f, 'r) instr -> ('b, 'r) instr } [@@unboxed] + { branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr } [@@unboxed] let merge_branches : type bef a b. int -> a judgement -> b judgement -> @@ -296,19 +292,19 @@ let merge_branches bef judgement tzresult Lwt.t = fun loc btr bfr { branch } -> match btr, bfr with - | Typed (ibt, aftbt), Typed (ibf, aftbf) -> + | Typed ({ aft = aftbt } as dbt), Typed ({ aft = aftbf } as dbf) -> trace (Unmatched_branches (loc, Stack_ty aftbt, Stack_ty aftbf)) (Lwt.return (stack_ty_eq 0 aftbt aftbf)) >>=? fun (Eq _) -> - return (Typed (branch ibt ibf, aftbt)) - | Failed { instr = instrt }, Failed { instr = instrf } -> - let instr ret = - branch (instrt ret) (instrf ret) in - return (Failed { instr }) - | Typed (ibt, aftbt), Failed { instr = instrf } -> - return (Typed (branch ibt (instrf aftbt), aftbt)) - | Failed { instr = instrt }, Typed (ibf, aftbf) -> - return (Typed (branch (instrt aftbf) ibf, aftbf)) + return (Typed (branch dbt dbf)) + | Failed { descr = descrt }, Failed { descr = descrf } -> + let descr ret = + branch (descrt ret) (descrf ret) in + return (Failed { descr }) + | Typed dbt, Failed { descr = descrf } -> + return (Typed (branch dbt (descrf dbt.aft))) + | Failed { descr = descrt }, Typed dbf -> + return (Typed (branch (descrt dbf.aft) dbf)) type ex_comparable_ty = Ex : 'a comparable_ty -> ex_comparable_ty @@ -760,631 +756,629 @@ and parse_untagged_comparable_data and parse_lambda : type arg ret storage. context -> - ?log: (int -> (stack_ty_val * stack_ty_val) -> unit) -> ?storage_type: storage ty -> arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t = - fun ctxt ?log ?storage_type arg ret script_instr -> - let loc = location script_instr in - parse_instr ctxt ?log ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function - | Typed (instr, (Item_t (ty, Empty_t) as stack_ty)) -> + fun ctxt ?storage_type arg ret script_instr -> + parse_instr ctxt ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function + | Typed ({ loc ; aft = (Item_t (ty, Empty_t) as stack_ty) } as descr) -> trace (Bad_return (loc, Stack_ty stack_ty, Ty ret)) (Lwt.return (ty_eq ty ret)) >>=? fun (Eq _) -> - return (Lam (instr, script_instr) : (arg, ret) lambda) - | Typed (_, stack_ty) -> + return (Lam (descr, script_instr) : (arg, ret) lambda) + | Typed { loc ; aft = stack_ty } -> fail (Bad_return (loc, Stack_ty stack_ty, Ty ret)) - | Failed { instr } -> - return (Lam (instr (Item_t (ret, Empty_t)), script_instr) : (arg, ret) lambda) + | Failed { descr } -> + return (Lam (descr (Item_t (ret, Empty_t)), script_instr) : (arg, ret) lambda) and parse_instr : type bef storage. context -> - ?log: (int -> (stack_ty_val * stack_ty_val) -> unit) -> ?storage_type: storage ty -> Script.expr -> bef stack_ty -> bef judgement tzresult Lwt.t = - fun ctxt ?log ?storage_type script_instr stack_ty -> + fun ctxt ?storage_type script_instr stack_ty -> let return : bef judgement -> bef judgement tzresult Lwt.t = return in let check_item_ty got exp pos n = ty_eq got exp |> record_trace (Bad_stack_item (pos, n)) |> Lwt.return in - begin match script_instr, stack_ty with - (* stack ops *) - | Prim (_, "drop", []), - Item_t (_, rest) -> - return (Typed (Drop, rest)) - | Prim (_, "dup", []), - Item_t (v, rest) -> - return (Typed (Dup, Item_t (v, Item_t (v, rest)))) - | Prim (_, "swap", []), - Item_t (v, Item_t (w, rest)) -> - return (Typed (Swap, Item_t (w, Item_t (v, rest)))) - | Prim (_, "push", [ td ]), - stack -> - parse_tagged_data ctxt td >>=? fun (Ex (t, v)) -> - return (Typed (Const v, Item_t (t, stack))) - (* options *) - | Prim (_, "some", []), - Item_t (t, rest) -> - return (Typed (Cons_some, Item_t (Option_t t, rest))) - | Prim (_, "none", [ t ]), - stack -> - parse_ty t >>=? fun (Ex t) -> - return (Typed (Cons_none t, Item_t (Option_t t, stack))) - | Prim (loc, "if_none", [ bt ; bf ]), - Item_t (Option_t t, rest) -> - expect_sequence_parameter loc Instr "if_none" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if_none" 1 bf >>=? fun () -> - parse_instr ?log ?storage_type ctxt bt rest >>=? fun btr -> - parse_instr ?log ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun bfr -> - let branch ibt ibf = If_none (ibt, ibf) in - merge_branches loc btr bfr { branch } - (* pairs *) - | Prim (_, "pair", []), - Item_t (a, Item_t (b, rest)) -> - return (Typed (Cons_pair, Item_t (Pair_t(a, b), rest))) - | Prim (_, "car", []), - Item_t (Pair_t (a, _), rest) -> - return (Typed (Car, Item_t (a, rest))) - | Prim (_, "cdr", []), - Item_t (Pair_t (_, b), rest) -> - return (Typed (Cdr, Item_t (b, rest))) - (* unions *) - | Prim (_, "left", [ tr ]), - Item_t (tl, rest) -> - parse_ty tr >>=? fun (Ex tr) -> - return (Typed (Left, Item_t (Union_t (tl, tr), rest))) - | Prim (_, "right", [ tl ]), - Item_t (tr, rest) -> - parse_ty tl >>=? fun (Ex tl) -> - return (Typed (Right, Item_t (Union_t (tl, tr), rest))) - | Prim (loc, "if_left", [ bt ; bf ]), - Item_t (Union_t (tl, tr), rest) -> - expect_sequence_parameter loc Instr "if_left" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if_left" 1 bf >>=? fun () -> - parse_instr ?log ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun btr -> - parse_instr ?log ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun bfr -> - let branch ibt ibf = If_left (ibt, ibf) in - merge_branches loc btr bfr { branch } - (* lists *) - | Prim (_, "nil", [ t ]), - stack -> - parse_ty t >>=? fun (Ex t) -> - return (Typed (Nil, Item_t (List_t t, stack))) - | Prim (loc, "cons", []), - Item_t (tv, Item_t (List_t t, rest)) -> - trace - (Bad_stack_item (loc, 2)) - (Lwt.return (ty_eq t tv)) >>=? fun (Eq _) -> - return (Typed (Cons_list, Item_t (List_t t, rest))) - | Prim (loc, "if_cons", [ bt ; bf ]), - Item_t (List_t t, rest) -> - expect_sequence_parameter loc Instr "if_cons" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if_cons" 1 bf >>=? fun () -> - parse_instr ?log ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr -> - parse_instr ?log ?storage_type ctxt bf rest >>=? fun bfr -> - let branch ibt ibf = If_cons (ibt, ibf) in - merge_branches loc btr bfr { branch } - | Prim (loc, "map", []), - Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> - check_item_ty elt param loc 2 >>=? fun (Eq _) -> - return (Typed (List_map, Item_t (List_t ret, rest))) - | Prim (loc, "reduce", []), - Item_t (Lambda_t (Pair_t (pelt, pr), r), - Item_t (List_t elt, Item_t (init, rest))) -> - check_item_ty r pr loc 1 >>=? fun (Eq _) -> - check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> - check_item_ty init r loc 3 >>=? fun (Eq _) -> - return (Typed (List_reduce, Item_t (r, rest))) - (* sets *) - | Prim (_, "empty_set", [ t ]), - rest -> - parse_comparable_ty t >>=? fun (Ex t) -> - return (Typed (Empty_set t, Item_t (Set_t t, rest))) - | Prim (loc, "map", []), - Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> - let elt = ty_of_comparable_ty elt in - trace (Bad_stack_item (loc, 1)) (Lwt.return (comparable_ty_of_ty ret)) >>=? fun ret -> - check_item_ty elt param loc 2 >>=? fun (Eq _) -> - return (Typed (Set_map ret, Item_t (Set_t ret, rest))) - | Prim (loc, "reduce", []), - Item_t (Lambda_t (Pair_t (pelt, pr), r), - Item_t (Set_t elt, Item_t (init, rest))) -> - let elt = ty_of_comparable_ty elt in - check_item_ty r pr loc 1 >>=? fun (Eq _) -> - check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> - check_item_ty init r loc 3 >>=? fun (Eq _) -> - return (Typed (Set_reduce, Item_t (r, rest))) - | Prim (loc, "mem", []), - Item_t (v, Item_t (Set_t elt, rest)) -> - let elt = ty_of_comparable_ty elt in - check_item_ty elt v loc 2 >>=? fun (Eq _) -> - return (Typed (Set_mem, Item_t (Bool_t, rest))) - | Prim (loc, "update", []), - Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> - let ty = ty_of_comparable_ty elt in - check_item_ty ty v loc 3 >>=? fun (Eq _) -> - return (Typed (Set_update, Item_t (Set_t elt, rest))) - (* maps *) - | Prim (_, "empty_map", [ tk ; tv ]), - stack -> - parse_comparable_ty tk >>=? fun (Ex tk) -> - parse_ty tv >>=? fun (Ex tv) -> - return (Typed (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) - | Prim (loc, "map", []), - Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> - let k = ty_of_comparable_ty ck in - check_item_ty pk k loc 2 >>=? fun (Eq _) -> - check_item_ty pv v loc 2 >>=? fun (Eq _) -> - return (Typed (Map_map, Item_t (Map_t (ck, ret), rest))) - | Prim (loc, "reduce", []), - Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), - Item_t (Map_t (ck, v), Item_t (init, rest))) -> - let k = ty_of_comparable_ty ck in - check_item_ty pk k loc 2 >>=? fun (Eq _) -> - check_item_ty pv v loc 2 >>=? fun (Eq _) -> - check_item_ty r pr loc 1 >>=? fun (Eq _) -> - check_item_ty init r loc 3 >>=? fun (Eq _) -> - return (Typed (Map_reduce, Item_t (r, rest))) - | Prim (loc, "mem", []), - Item_t (vk, Item_t (Map_t (ck, _), rest)) -> - let k = ty_of_comparable_ty ck in - check_item_ty vk k loc 1 >>=? fun (Eq _) -> - return (Typed (Map_mem, Item_t (Bool_t, rest))) - | Prim (loc, "get", []), - Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> - let k = ty_of_comparable_ty ck in - check_item_ty vk k loc 1 >>=? fun (Eq _) -> - return (Typed (Map_get, Item_t (Option_t elt, rest))) - | Prim (loc, "update", []), - Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> - let k = ty_of_comparable_ty ck in - check_item_ty vk k loc 1 >>=? fun (Eq _) -> - check_item_ty vv v loc 2 >>=? fun (Eq _) -> - return (Typed (Map_update, Item_t (Map_t (ck, v), rest))) - (* control *) - | Seq (_, []), - stack -> - return (Typed (Nop, stack)) - | Seq (_, [ single ]), - stack -> - parse_instr ?log ?storage_type ctxt single stack - | Seq (loc, hd :: tl), - stack -> - parse_instr ?log ?storage_type ctxt hd stack >>=? begin function - | Failed _ -> - fail (Fail_not_in_tail_position loc) - | Typed (ihd, trans) -> - parse_instr ?log ?storage_type ctxt (Seq (loc, tl)) trans >>=? function - | Failed { instr } -> - let instr ret = Seq (ihd, instr ret) in - return (Failed { instr }) - | Typed (itl, aft) -> - return (Typed (Seq (ihd, itl), aft)) - end - | Prim (loc, "if", [ bt ; bf ]), - Item_t (Bool_t, rest) -> - expect_sequence_parameter loc Instr "if" 0 bt >>=? fun () -> - expect_sequence_parameter loc Instr "if" 1 bf >>=? fun () -> - parse_instr ?log ?storage_type ctxt bt rest >>=? fun btr -> - parse_instr ?log ?storage_type ctxt bf rest >>=? fun bfr -> - let branch ibt ibf = If (ibt, ibf) in - merge_branches loc btr bfr { branch } - | Prim (loc, "loop", [ body ]), - (Item_t (Bool_t, rest) as stack) -> - expect_sequence_parameter loc Instr "loop" 0 body >>=? fun () -> - parse_instr ?log ?storage_type ctxt body rest >>=? begin function - | Typed (ibody, aftbody) -> - trace - (Unmatched_branches (loc, Stack_ty aftbody, Stack_ty stack)) - (Lwt.return (stack_ty_eq 0 aftbody stack)) >>=? fun (Eq _) -> - return (Typed (Loop ibody, rest)) - | Failed { instr } -> - let ibody = instr (Item_t (Bool_t, rest)) in - return (Typed (Loop ibody, rest)) - end - | Prim (loc, "lambda", [ arg ; ret ; code ]), - stack -> - parse_ty arg >>=? fun (Ex arg) -> - parse_ty ret >>=? fun (Ex ret) -> - expect_sequence_parameter loc Instr "lambda" 2 code >>=? fun () -> - parse_lambda ctxt ?log arg ret code >>=? fun lambda -> - return (Typed (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) - | Prim (loc, "exec", []), - Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> - check_item_ty arg param loc 1 >>=? fun (Eq _) -> - return (Typed (Exec, Item_t (ret, rest))) - | Prim (loc, "dip", [ code ]), - Item_t (v, rest) -> - expect_sequence_parameter loc Instr "dip" 0 code >>=? fun () -> - parse_instr ?log ctxt code rest >>=? begin function - | Typed (instr, aft_rest) -> - return (Typed (Dip instr, Item_t (v, aft_rest))) - | Failed _ -> - fail (Fail_not_in_tail_position loc) - end - | Prim (loc, "fail", []), - _ -> - let instr _ = Fail loc in - return (Failed { instr }) - | Prim (_, "nop", []), - stack -> - return (Typed (Nop, stack)) - (* timestamp operations *) - | Prim (loc, "add", []), - Item_t (Timestamp_t, Item_t (Int_t kind, rest)) -> - trace - (Bad_stack_item (loc, 2)) - (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Add_timestamp_to_seconds (kind, loc), Item_t (Timestamp_t, rest))) - | Prim (loc, "add", []), - Item_t (Int_t kind, Item_t (Timestamp_t, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Add_seconds_to_timestamp (kind, loc), Item_t (Timestamp_t, rest))) - (* string operations *) - | Prim (_, "concat", []), - Item_t (String_t, Item_t (String_t, rest)) -> - return (Typed (Concat, Item_t (String_t, rest))) - (* currency operations *) - | Prim (_, "add", []), - Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (Typed (Add_tez, Item_t (Tez_t, rest))) - | Prim (_, "sub", []), - Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (Typed (Sub_tez, Item_t (Tez_t, rest))) - | Prim (loc, "mul", []), - Item_t (Tez_t, Item_t (Int_t kind, rest)) -> - trace - (Bad_stack_item (loc, 2)) - (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Mul_tez kind, Item_t (Tez_t, rest))) - | Prim (loc, "mul", []), - Item_t (Int_t kind, Item_t (Tez_t, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> - return (Typed (Mul_tez' kind, Item_t (Tez_t, rest))) - (* boolean operations *) - | Prim (_, "or", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (Or, Item_t (Bool_t, rest))) - | Prim (_, "and", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (And, Item_t (Bool_t, rest))) - | Prim (_, "xor", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (Xor, Item_t (Bool_t, rest))) - | Prim (_, "not", []), - Item_t (Bool_t, rest) -> - return (Typed (Not, Item_t (Bool_t, rest))) - (* integer operations *) - | Prim (loc, "checked_abs", []), - Item_t (Int_t k, rest) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Checked_abs_int (k, loc), Item_t (Int_t k, rest))) - | Prim (loc, "checked_neg", []), - Item_t (Int_t k, rest) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Checked_neg_int (k, loc), Item_t (Int_t k, rest))) - | Prim (loc, "checked_add", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Checked_add_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "checked_sub", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Checked_sub_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "checked_mul", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Checked_mul_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "abs", []), - Item_t (Int_t k, rest) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Abs_int k, Item_t (Int_t k, rest))) - | Prim (loc, "neg", []), - Item_t (Int_t k, rest) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Neg_int k, Item_t (Int_t k, rest))) - | Prim (loc, "add", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Add_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "sub", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Sub_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "mul", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Mul_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "div", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Div_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "mod", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Mod_int (kl, loc), Item_t (Int_t kl, rest))) - | Prim (loc, "lsl", []), - Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Lsl_int k, Item_t (Int_t k, rest))) - | Prim (loc, "lsr", []), - Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Lsr_int k, Item_t (Int_t k, rest))) - | Prim (loc, "or", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> - trace - (Bad_stack_item (loc, 2)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Or_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "and", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> - trace - (Bad_stack_item (loc, 2)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (And_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "xor", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> - trace - (Bad_stack_item (loc, 2)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Xor_int kl, Item_t (Int_t kl, rest))) - | Prim (loc, "not", []), - Item_t (Int_t k, rest) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> - return (Typed (Not_int k, Item_t (Int_t k, rest))) - (* comparison *) - | Prim (loc, "compare", []), - Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> - trace - (Bad_stack_item (loc, 1)) - (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> - return (Typed (Compare (Int_key kl), Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Bool_t, Item_t (Bool_t, rest)) -> - return (Typed (Compare Bool_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (String_t, Item_t (String_t, rest)) -> - return (Typed (Compare String_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Tez_t, Item_t (Tez_t, rest)) -> - return (Typed (Compare Tez_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Key_t, Item_t (Key_t, rest)) -> - return (Typed (Compare Key_key, Item_t (Int_t Int64, rest))) - | Prim (_, "compare", []), - Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> - return (Typed (Compare Timestamp_key, Item_t (Int_t Int64, rest))) - (* comparators *) - | Prim (_, "eq", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Eq, Item_t (Bool_t, rest))) - | Prim (_, "neq", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Neq, Item_t (Bool_t, rest))) - | Prim (_, "lt", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Lt, Item_t (Bool_t, rest))) - | Prim (_, "gt", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Gt, Item_t (Bool_t, rest))) - | Prim (_, "le", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Le, Item_t (Bool_t, rest))) - | Prim (_, "ge", []), - Item_t (Int_t Int64, rest) -> - return (Typed (Ge, Item_t (Bool_t, rest))) - (* casts *) - | Prim (loc, "checked_cast", [ t ]), - stack -> - parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with - | Int_t kt, - Item_t (Int_t kf, rest) -> - return (Typed (Checked_int_of_int (kf, kt, loc), - Item_t (Int_t kt, rest))) - | ty, Item_t (ty', _) -> - fail (Undefined_cast (loc, Ty ty', Ty ty)) - | _, Empty_t -> - fail (Bad_stack (loc, 1, Stack_ty stack)) - end - | Prim (loc, "cast", [ t ]), - stack -> - parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with - | Int_t kt, Item_t (Int_t kf, rest) -> - return (Typed (Int_of_int (kf, kt), - Item_t (Int_t kt, rest))) - | ty, Item_t (ty', _) -> - fail (Undefined_cast (loc, Ty ty', Ty ty)) - | _, Empty_t -> - fail (Bad_stack (loc, 1, Stack_ty stack)) - end - (* protocol *) - | Prim (_, "manager", []), - Item_t (Contract_t _, rest) -> - return (Typed (Manager, Item_t (Key_t, rest))) - | Prim (loc, "transfer_tokens", []), - Item_t (p, Item_t - (Tez_t, Item_t - (Contract_t (cp, cr), Item_t - (storage, Empty_t)))) -> - check_item_ty p cp loc 1 >>=? fun (Eq _) -> - begin match storage_type with - | Some storage_type -> - check_item_ty storage storage_type loc 3 >>=? fun (Eq _) -> - return (Typed (Transfer_tokens (storage, loc), - Item_t (cr, Item_t (storage, Empty_t)))) - | None -> - fail (Transfer_in_lambda loc) - end - | Prim (_, "create_account", []), - Item_t - (Key_t, Item_t - (Option_t Key_t, Item_t - (Bool_t, Item_t - (Tez_t, rest)))) -> - return (Typed (Create_account, - Item_t (Contract_t (Void_t, Void_t), rest))) - | Prim (loc, "create_contract", []), - Item_t - (Key_t, Item_t - (Option_t Key_t, Item_t - (Bool_t, Item_t - (Tez_t, Item_t - (Lambda_t (Pair_t (Pair_t (Tez_t, p), gp), - Pair_t (r, gr)), Item_t - (ginit, rest)))))) -> - check_item_ty gp gr loc 5 >>=? fun (Eq _) -> - check_item_ty ginit gp loc 6 >>=? fun (Eq _) -> - return (Typed (Create_contract (gp, p, r), - Item_t (Contract_t (p, r), rest))) - | Prim (_, "now", []), - stack -> - return (Typed (Now, Item_t (Timestamp_t, stack))) - | Prim (_, "amount", []), - stack -> - return (Typed (Amount, Item_t (Tez_t, stack))) - | Prim (_, "balance", []), - stack -> - return (Typed (Balance, Item_t (Tez_t, stack))) - | Prim (_, "check_signature", []), - Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> - return (Typed (Check_signature, Item_t (Bool_t, rest))) - | Prim (_, "h", []), - Item_t (t, rest) -> - return (Typed (H t, Item_t (String_t, rest))) - | Prim (_, "steps_to_quota", []), - stack -> - return (Typed (Steps_to_quota, Item_t (Int_t Uint32, stack))) - | Prim (_, "source", [ ta; tb ]), - stack -> - parse_ty ta >>=? fun (Ex ta) -> - parse_ty tb >>=? fun (Ex tb) -> - return (Typed (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) - (* Primitive parsing errors *) - | Prim (loc, ("drop" | "dup" | "swap" | "some" - | "pair" | "car" | "cdr" | "cons" - | "mem" | "update" | "map" | "reduce" - | "get" | "ref" | "deref" - | "set" | "exec" | "fail" | "nop" - | "concat" | "add" | "sub" - | "mul" | "floor" | "ceil" | "inf" - | "nan" | "isnan" | "nanan" - | "div" | "mod" | "or" | "and" | "xor" - | "not" | "checked_abs" | "checked_neg" - | "checked_add" | "checked_sub" | "checked_mul" - | "abs" | "neg" | "lsl" | "lsr" - | "compare" | "eq" | "neq" - | "lt" | "gt" | "le" | "ge" - | "manager" | "transfer_tokens" | "create_account" - | "create_contract" | "now" | "amount" | "balance" - | "check_signature" | "h" | "steps_to_quota" - as name), (_ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, name, 0, List.length l)) - | Prim (loc, ( "push" | "none" | "left" | "right" | "nil" - | "empty_set" | "dip" | "checked_cast" | "cast" | "loop" - as name), ([] | _ :: _ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, name, 1, List.length l)) - | Prim (loc, ("if_none" | "if_left" | "if_cons" - | "empty_map" | "if" | "source" - as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, name, 2, List.length l)) - | Prim (loc, "lambda", ([] | [ _ ] | [ _; _ ] - | _ :: _ :: _ :: _ :: _ as l)), _ -> - fail (Invalid_arity (loc, Instr, "lambda", 3, List.length l)) - (* Stack errors *) - | Prim (loc, ("add" | "sub" | "mul" | "div" | "mod" - | "and" | "or" | "xor" | "lsl" | "lsr" - | "concat" | "compare" - | "checked_abs" | "checked_neg" - | "checked_add" | "checked_sub" | "checked_mul" as name), []), - Item_t (ta, Item_t (tb, _)) -> - fail (Undefined_binop (loc, name, Ty ta, Ty tb)) - | Prim (loc, ("neg" | "abs" | "not" | "floor" | "ceil" - | "isnan" | "nanan" | "eq" - | "neq" | "lt" | "gt" | "le" | "ge" as name), []), - Item_t (t, _) -> - fail (Undefined_unop (loc, name, Ty t)) - | Prim (loc, ("reduce" | "update"), []), - stack -> - fail (Bad_stack (loc, 3, Stack_ty stack)) - | Prim (loc, "create_contract", []), - stack -> - fail (Bad_stack (loc, 6, Stack_ty stack)) - | Prim (loc, "create_account", []), - stack -> - fail (Bad_stack (loc, 4, Stack_ty stack)) - | Prim (loc, "transfer_tokens", []), - stack -> - fail (Bad_stack (loc, 3, Stack_ty stack)) - | Prim (loc, ("drop" | "dup" | "car" | "cdr" | "some" | "h" | "dip" - | "if_none" | "left" | "right" | "if_left" | "if" - | "loop" | "if_cons" | "ref" | "deref" | "manager" - | "neg" | "abs" | "not" | "floor" | "ceil" | "isnan" | "nanan" - | "eq" | "neq" | "lt" | "gt" | "le" | "ge"), _), - stack -> - fail (Bad_stack (loc, 1, Stack_ty stack)) - | Prim (loc, ("swap" | "pair" | "cons" | "set" | "incr" | "decr" - | "map" | "get" | "mem" | "exec" - | "check_signature" | "add" | "sub" | "mul" - | "div" | "mod" | "and" | "or" | "xor" - | "lsl" | "lsr" | "concat" - | "checked_abs" | "checked_neg" | "checked_add" - | "checked_sub" | "checked_mul" | "compare"), _), - stack -> - fail (Bad_stack (loc, 2, Stack_ty stack)) - (* Generic parsing errors *) - | Prim (loc, prim, _), _ -> - fail @@ Invalid_primitive (loc, Instr, prim) - | (Int (loc, _) | String (loc, _)), _ -> - fail @@ Invalid_expression_kind loc - end >>=? fun judgement -> - begin match judgement, script_instr, log with - | Typed (_, after_ty), Prim (loc, _, _), Some log -> - log loc (Stack_ty stack_ty, Stack_ty after_ty) - | _ -> () - end ; - return judgement + let typed loc (instr, aft) = + Typed { loc ; instr ; bef = stack_ty ; aft } in + match script_instr, stack_ty with + (* stack ops *) + | Prim (loc, "drop", []), + Item_t (_, rest) -> + return (typed loc (Drop, rest)) + | Prim (loc, "dup", []), + Item_t (v, rest) -> + return (typed loc (Dup, Item_t (v, Item_t (v, rest)))) + | Prim (loc, "swap", []), + Item_t (v, Item_t (w, rest)) -> + return (typed loc (Swap, Item_t (w, Item_t (v, rest)))) + | Prim (loc, "push", [ td ]), + stack -> + parse_tagged_data ctxt td >>=? fun (Ex (t, v)) -> + return (typed loc (Const v, Item_t (t, stack))) + (* options *) + | Prim (loc, "some", []), + Item_t (t, rest) -> + return (typed loc (Cons_some, Item_t (Option_t t, rest))) + | Prim (loc, "none", [ t ]), + stack -> + parse_ty t >>=? fun (Ex t) -> + return (typed loc (Cons_none t, Item_t (Option_t t, stack))) + | Prim (loc, "if_none", [ bt ; bf ]), + (Item_t (Option_t t, rest) as bef) -> + expect_sequence_parameter loc Instr "if_none" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_none" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt rest >>=? fun btr -> + parse_instr ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun bfr -> + let branch ibt ibf = + { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches loc btr bfr { branch } + (* pairs *) + | Prim (loc, "pair", []), + Item_t (a, Item_t (b, rest)) -> + return (typed loc (Cons_pair, Item_t (Pair_t(a, b), rest))) + | Prim (loc, "car", []), + Item_t (Pair_t (a, _), rest) -> + return (typed loc (Car, Item_t (a, rest))) + | Prim (loc, "cdr", []), + Item_t (Pair_t (_, b), rest) -> + return (typed loc (Cdr, Item_t (b, rest))) + (* unions *) + | Prim (loc, "left", [ tr ]), + Item_t (tl, rest) -> + parse_ty tr >>=? fun (Ex tr) -> + return (typed loc (Left, Item_t (Union_t (tl, tr), rest))) + | Prim (loc, "right", [ tl ]), + Item_t (tr, rest) -> + parse_ty tl >>=? fun (Ex tl) -> + return (typed loc (Right, Item_t (Union_t (tl, tr), rest))) + | Prim (loc, "if_left", [ bt ; bf ]), + (Item_t (Union_t (tl, tr), rest) as bef) -> + expect_sequence_parameter loc Instr "if_left" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_left" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun btr -> + parse_instr ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun bfr -> + let branch ibt ibf = + { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches loc btr bfr { branch } + (* lists *) + | Prim (loc, "nil", [ t ]), + stack -> + parse_ty t >>=? fun (Ex t) -> + return (typed loc (Nil, Item_t (List_t t, stack))) + | Prim (loc, "cons", []), + Item_t (tv, Item_t (List_t t, rest)) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (ty_eq t tv)) >>=? fun (Eq _) -> + return (typed loc (Cons_list, Item_t (List_t t, rest))) + | Prim (loc, "if_cons", [ bt ; bf ]), + (Item_t (List_t t, rest) as bef) -> + expect_sequence_parameter loc Instr "if_cons" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if_cons" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr -> + parse_instr ?storage_type ctxt bf rest >>=? fun bfr -> + let branch ibt ibf = + { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches loc btr bfr { branch } + | Prim (loc, "map", []), + Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (typed loc (List_map, Item_t (List_t ret, rest))) + | Prim (loc, "reduce", []), + Item_t (Lambda_t (Pair_t (pelt, pr), r), + Item_t (List_t elt, Item_t (init, rest))) -> + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (typed loc (List_reduce, Item_t (r, rest))) + (* sets *) + | Prim (loc, "empty_set", [ t ]), + rest -> + parse_comparable_ty t >>=? fun (Ex t) -> + return (typed loc (Empty_set t, Item_t (Set_t t, rest))) + | Prim (loc, "map", []), + Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + trace (Bad_stack_item (loc, 1)) (Lwt.return (comparable_ty_of_ty ret)) >>=? fun ret -> + check_item_ty elt param loc 2 >>=? fun (Eq _) -> + return (typed loc (Set_map ret, Item_t (Set_t ret, rest))) + | Prim (loc, "reduce", []), + Item_t (Lambda_t (Pair_t (pelt, pr), r), + Item_t (Set_t elt, Item_t (init, rest))) -> + let elt = ty_of_comparable_ty elt in + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty elt pelt loc 2 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (typed loc (Set_reduce, Item_t (r, rest))) + | Prim (loc, "mem", []), + Item_t (v, Item_t (Set_t elt, rest)) -> + let elt = ty_of_comparable_ty elt in + check_item_ty elt v loc 2 >>=? fun (Eq _) -> + return (typed loc (Set_mem, Item_t (Bool_t, rest))) + | Prim (loc, "update", []), + Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> + let ty = ty_of_comparable_ty elt in + check_item_ty ty v loc 3 >>=? fun (Eq _) -> + return (typed loc (Set_update, Item_t (Set_t elt, rest))) + (* maps *) + | Prim (loc, "empty_map", [ tk ; tv ]), + stack -> + parse_comparable_ty tk >>=? fun (Ex tk) -> + parse_ty tv >>=? fun (Ex tv) -> + return (typed loc (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) + | Prim (loc, "map", []), + Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + return (typed loc (Map_map, Item_t (Map_t (ck, ret), rest))) + | Prim (loc, "reduce", []), + Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), + Item_t (Map_t (ck, v), Item_t (init, rest))) -> + let k = ty_of_comparable_ty ck in + check_item_ty pk k loc 2 >>=? fun (Eq _) -> + check_item_ty pv v loc 2 >>=? fun (Eq _) -> + check_item_ty r pr loc 1 >>=? fun (Eq _) -> + check_item_ty init r loc 3 >>=? fun (Eq _) -> + return (typed loc (Map_reduce, Item_t (r, rest))) + | Prim (loc, "mem", []), + Item_t (vk, Item_t (Map_t (ck, _), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + return (typed loc (Map_mem, Item_t (Bool_t, rest))) + | Prim (loc, "get", []), + Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + return (typed loc (Map_get, Item_t (Option_t elt, rest))) + | Prim (loc, "update", []), + Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> + let k = ty_of_comparable_ty ck in + check_item_ty vk k loc 1 >>=? fun (Eq _) -> + check_item_ty vv v loc 2 >>=? fun (Eq _) -> + return (typed loc (Map_update, Item_t (Map_t (ck, v), rest))) + (* control *) + | Seq (loc, []), + stack -> + return (typed loc (Nop, stack)) + | Seq (_, [ single ]), + stack -> + parse_instr ?storage_type ctxt single stack + | Seq (loc, hd :: tl), + stack -> + parse_instr ?storage_type ctxt hd stack >>=? begin function + | Failed _ -> + fail (Fail_not_in_tail_position loc) + | Typed ({ aft = middle } as ihd) -> + parse_instr ?storage_type ctxt (Seq (loc, tl)) middle >>=? function + | Failed { descr } -> + let descr ret = + { loc ; instr = Seq (ihd, descr ret) ; + bef = stack ; aft = ret } in + return (Failed { descr }) + | Typed itl -> + return (typed loc (Seq (ihd, itl), itl.aft)) + end + | Prim (loc, "if", [ bt ; bf ]), + (Item_t (Bool_t, rest) as bef) -> + expect_sequence_parameter loc Instr "if" 0 bt >>=? fun () -> + expect_sequence_parameter loc Instr "if" 1 bf >>=? fun () -> + parse_instr ?storage_type ctxt bt rest >>=? fun btr -> + parse_instr ?storage_type ctxt bf rest >>=? fun bfr -> + let branch ibt ibf = + { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in + merge_branches loc btr bfr { branch } + | Prim (loc, "loop", [ body ]), + (Item_t (Bool_t, rest) as stack) -> + expect_sequence_parameter loc Instr "loop" 0 body >>=? fun () -> + parse_instr ?storage_type ctxt body rest >>=? begin function + | Typed ibody -> + trace + (Unmatched_branches (loc, Stack_ty ibody.aft, Stack_ty stack)) + (Lwt.return (stack_ty_eq 0 ibody.aft stack)) >>=? fun (Eq _) -> + return (typed loc (Loop ibody, rest)) + | Failed { descr } -> + let ibody = descr (Item_t (Bool_t, rest)) in + return (typed loc (Loop ibody, rest)) + end + | Prim (loc, "lambda", [ arg ; ret ; code ]), + stack -> + parse_ty arg >>=? fun (Ex arg) -> + parse_ty ret >>=? fun (Ex ret) -> + expect_sequence_parameter loc Instr "lambda" 2 code >>=? fun () -> + parse_lambda ctxt arg ret code >>=? fun lambda -> + return (typed loc (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) + | Prim (loc, "exec", []), + Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> + check_item_ty arg param loc 1 >>=? fun (Eq _) -> + return (typed loc (Exec, Item_t (ret, rest))) + | Prim (loc, "dip", [ code ]), + Item_t (v, rest) -> + expect_sequence_parameter loc Instr "dip" 0 code >>=? fun () -> + parse_instr ctxt code rest >>=? begin function + | Typed descr -> + return (typed loc (Dip descr, Item_t (v, descr.aft))) + | Failed _ -> + fail (Fail_not_in_tail_position loc) + end + | Prim (loc, "fail", []), + bef -> + let descr aft = { loc ; instr = Fail ; bef ; aft } in + return (Failed { descr }) + | Prim (loc, "nop", []), + stack -> + return (typed loc (Nop, stack)) + (* timestamp operations *) + | Prim (loc, "add", []), + Item_t (Timestamp_t, Item_t (Int_t kind, rest)) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (typed loc (Add_timestamp_to_seconds kind, Item_t (Timestamp_t, rest))) + | Prim (loc, "add", []), + Item_t (Int_t kind, Item_t (Timestamp_t, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (typed loc (Add_seconds_to_timestamp kind, Item_t (Timestamp_t, rest))) + (* string operations *) + | Prim (loc, "concat", []), + Item_t (String_t, Item_t (String_t, rest)) -> + return (typed loc (Concat, Item_t (String_t, rest))) + (* currency operations *) + | Prim (loc, "add", []), + Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (typed loc (Add_tez, Item_t (Tez_t, rest))) + | Prim (loc, "sub", []), + Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (typed loc (Sub_tez, Item_t (Tez_t, rest))) + | Prim (loc, "mul", []), + Item_t (Tez_t, Item_t (Int_t kind, rest)) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (typed loc (Mul_tez kind, Item_t (Tez_t, rest))) + | Prim (loc, "mul", []), + Item_t (Int_t kind, Item_t (Tez_t, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) -> + return (typed loc (Mul_tez' kind, Item_t (Tez_t, rest))) + (* boolean operations *) + | Prim (loc, "or", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (typed loc (Or, Item_t (Bool_t, rest))) + | Prim (loc, "and", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (typed loc (And, Item_t (Bool_t, rest))) + | Prim (loc, "xor", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (typed loc (Xor, Item_t (Bool_t, rest))) + | Prim (loc, "not", []), + Item_t (Bool_t, rest) -> + return (typed loc (Not, Item_t (Bool_t, rest))) + (* integer operations *) + | Prim (loc, "checked_abs", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (typed loc (Checked_abs_int k, Item_t (Int_t k, rest))) + | Prim (loc, "checked_neg", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (typed loc (Checked_neg_int k, Item_t (Int_t k, rest))) + | Prim (loc, "checked_add", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Checked_add_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "checked_sub", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Checked_sub_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "checked_mul", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Checked_mul_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "abs", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (typed loc (Abs_int k, Item_t (Int_t k, rest))) + | Prim (loc, "neg", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (signed_int_kind k)) >>=? fun (Eq _) -> + return (typed loc (Neg_int k, Item_t (Int_t k, rest))) + | Prim (loc, "add", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Add_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "sub", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Sub_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "mul", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Mul_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "div", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Div_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "mod", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Mod_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "lsl", []), + Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (typed loc (Lsl_int k, Item_t (Int_t k, rest))) + | Prim (loc, "lsr", []), + Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (typed loc (Lsr_int k, Item_t (Int_t k, rest))) + | Prim (loc, "or", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Or_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "and", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (And_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "xor", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind kl)) >>=? fun (Eq _) -> + trace + (Bad_stack_item (loc, 2)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Xor_int kl, Item_t (Int_t kl, rest))) + | Prim (loc, "not", []), + Item_t (Int_t k, rest) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (unsigned_int_kind k)) >>=? fun (Eq _) -> + return (typed loc (Not_int k, Item_t (Int_t k, rest))) + (* comparison *) + | Prim (loc, "compare", []), + Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> + trace + (Bad_stack_item (loc, 1)) + (Lwt.return (int_kind_eq kl kr)) >>=? fun (Eq _) -> + return (typed loc (Compare (Int_key kl), Item_t (Int_t Int64, rest))) + | Prim (loc, "compare", []), + Item_t (Bool_t, Item_t (Bool_t, rest)) -> + return (typed loc (Compare Bool_key, Item_t (Int_t Int64, rest))) + | Prim (loc, "compare", []), + Item_t (String_t, Item_t (String_t, rest)) -> + return (typed loc (Compare String_key, Item_t (Int_t Int64, rest))) + | Prim (loc, "compare", []), + Item_t (Tez_t, Item_t (Tez_t, rest)) -> + return (typed loc (Compare Tez_key, Item_t (Int_t Int64, rest))) + | Prim (loc, "compare", []), + Item_t (Key_t, Item_t (Key_t, rest)) -> + return (typed loc (Compare Key_key, Item_t (Int_t Int64, rest))) + | Prim (loc, "compare", []), + Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> + return (typed loc (Compare Timestamp_key, Item_t (Int_t Int64, rest))) + (* comparators *) + | Prim (loc, "eq", []), + Item_t (Int_t Int64, rest) -> + return (typed loc (Eq, Item_t (Bool_t, rest))) + | Prim (loc, "neq", []), + Item_t (Int_t Int64, rest) -> + return (typed loc (Neq, Item_t (Bool_t, rest))) + | Prim (loc, "lt", []), + Item_t (Int_t Int64, rest) -> + return (typed loc (Lt, Item_t (Bool_t, rest))) + | Prim (loc, "gt", []), + Item_t (Int_t Int64, rest) -> + return (typed loc (Gt, Item_t (Bool_t, rest))) + | Prim (loc, "le", []), + Item_t (Int_t Int64, rest) -> + return (typed loc (Le, Item_t (Bool_t, rest))) + | Prim (loc, "ge", []), + Item_t (Int_t Int64, rest) -> + return (typed loc (Ge, Item_t (Bool_t, rest))) + (* casts *) + | Prim (loc, "checked_cast", [ t ]), + stack -> + parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with + | Int_t kt, + Item_t (Int_t kf, rest) -> + return (typed loc (Checked_int_of_int (kf, kt), + Item_t (Int_t kt, rest))) + | ty, Item_t (ty', _) -> + fail (Undefined_cast (loc, Ty ty', Ty ty)) + | _, Empty_t -> + fail (Bad_stack (loc, 1, Stack_ty stack)) + end + | Prim (loc, "cast", [ t ]), + stack -> + parse_ty t >>=? fun (Ex ty) -> begin match ty, stack with + | Int_t kt, Item_t (Int_t kf, rest) -> + return (typed loc (Int_of_int (kf, kt), + Item_t (Int_t kt, rest))) + | ty, Item_t (ty', _) -> + fail (Undefined_cast (loc, Ty ty', Ty ty)) + | _, Empty_t -> + fail (Bad_stack (loc, 1, Stack_ty stack)) + end + (* protocol *) + | Prim (loc, "manager", []), + Item_t (Contract_t _, rest) -> + return (typed loc (Manager, Item_t (Key_t, rest))) + | Prim (loc, "transfer_tokens", []), + Item_t (p, Item_t + (Tez_t, Item_t + (Contract_t (cp, cr), Item_t + (storage, Empty_t)))) -> + check_item_ty p cp loc 1 >>=? fun (Eq _) -> + begin match storage_type with + | Some storage_type -> + check_item_ty storage storage_type loc 3 >>=? fun (Eq _) -> + return (typed loc (Transfer_tokens storage, + Item_t (cr, Item_t (storage, Empty_t)))) + | None -> + fail (Transfer_in_lambda loc) + end + | Prim (loc, "create_account", []), + Item_t + (Key_t, Item_t + (Option_t Key_t, Item_t + (Bool_t, Item_t + (Tez_t, rest)))) -> + return (typed loc (Create_account, + Item_t (Contract_t (Void_t, Void_t), rest))) + | Prim (loc, "create_contract", []), + Item_t + (Key_t, Item_t + (Option_t Key_t, Item_t + (Bool_t, Item_t + (Tez_t, Item_t + (Lambda_t (Pair_t (Pair_t (Tez_t, p), gp), + Pair_t (r, gr)), Item_t + (ginit, rest)))))) -> + check_item_ty gp gr loc 5 >>=? fun (Eq _) -> + check_item_ty ginit gp loc 6 >>=? fun (Eq _) -> + return (typed loc (Create_contract (gp, p, r), + Item_t (Contract_t (p, r), rest))) + | Prim (loc, "now", []), + stack -> + return (typed loc (Now, Item_t (Timestamp_t, stack))) + | Prim (loc, "amount", []), + stack -> + return (typed loc (Amount, Item_t (Tez_t, stack))) + | Prim (loc, "balance", []), + stack -> + return (typed loc (Balance, Item_t (Tez_t, stack))) + | Prim (loc, "check_signature", []), + Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> + return (typed loc (Check_signature, Item_t (Bool_t, rest))) + | Prim (loc, "h", []), + Item_t (t, rest) -> + return (typed loc (H t, Item_t (String_t, rest))) + | Prim (loc, "steps_to_quota", []), + stack -> + return (typed loc (Steps_to_quota, Item_t (Int_t Uint32, stack))) + | Prim (loc, "source", [ ta; tb ]), + stack -> + parse_ty ta >>=? fun (Ex ta) -> + parse_ty tb >>=? fun (Ex tb) -> + return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) + (* Primitive parsing errors *) + | Prim (loc, ("drop" | "dup" | "swap" | "some" + | "pair" | "car" | "cdr" | "cons" + | "mem" | "update" | "map" | "reduce" + | "get" | "ref" | "deref" + | "set" | "exec" | "fail" | "nop" + | "concat" | "add" | "sub" + | "mul" | "floor" | "ceil" | "inf" + | "nan" | "isnan" | "nanan" + | "div" | "mod" | "or" | "and" | "xor" + | "not" | "checked_abs" | "checked_neg" + | "checked_add" | "checked_sub" | "checked_mul" + | "abs" | "neg" | "lsl" | "lsr" + | "compare" | "eq" | "neq" + | "lt" | "gt" | "le" | "ge" + | "manager" | "transfer_tokens" | "create_account" + | "create_contract" | "now" | "amount" | "balance" + | "check_signature" | "h" | "steps_to_quota" + as name), (_ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 0, List.length l)) + | Prim (loc, ( "push" | "none" | "left" | "right" | "nil" + | "empty_set" | "dip" | "checked_cast" | "cast" | "loop" + as name), ([] | _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 1, List.length l)) + | Prim (loc, ("if_none" | "if_left" | "if_cons" + | "empty_map" | "if" | "source" + as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, name, 2, List.length l)) + | Prim (loc, "lambda", ([] | [ _ ] | [ _; _ ] + | _ :: _ :: _ :: _ :: _ as l)), _ -> + fail (Invalid_arity (loc, Instr, "lambda", 3, List.length l)) + (* Stack errors *) + | Prim (loc, ("add" | "sub" | "mul" | "div" | "mod" + | "and" | "or" | "xor" | "lsl" | "lsr" + | "concat" | "compare" + | "checked_abs" | "checked_neg" + | "checked_add" | "checked_sub" | "checked_mul" as name), []), + Item_t (ta, Item_t (tb, _)) -> + fail (Undefined_binop (loc, name, Ty ta, Ty tb)) + | Prim (loc, ("neg" | "abs" | "not" | "floor" | "ceil" + | "isnan" | "nanan" | "eq" + | "neq" | "lt" | "gt" | "le" | "ge" as name), []), + Item_t (t, _) -> + fail (Undefined_unop (loc, name, Ty t)) + | Prim (loc, ("reduce" | "update"), []), + stack -> + fail (Bad_stack (loc, 3, Stack_ty stack)) + | Prim (loc, "create_contract", []), + stack -> + fail (Bad_stack (loc, 6, Stack_ty stack)) + | Prim (loc, "create_account", []), + stack -> + fail (Bad_stack (loc, 4, Stack_ty stack)) + | Prim (loc, "transfer_tokens", []), + stack -> + fail (Bad_stack (loc, 3, Stack_ty stack)) + | Prim (loc, ("drop" | "dup" | "car" | "cdr" | "some" | "h" | "dip" + | "if_none" | "left" | "right" | "if_left" | "if" + | "loop" | "if_cons" | "ref" | "deref" | "manager" + | "neg" | "abs" | "not" | "floor" | "ceil" | "isnan" | "nanan" + | "eq" | "neq" | "lt" | "gt" | "le" | "ge"), _), + stack -> + fail (Bad_stack (loc, 1, Stack_ty stack)) + | Prim (loc, ("swap" | "pair" | "cons" | "set" | "incr" | "decr" + | "map" | "get" | "mem" | "exec" + | "check_signature" | "add" | "sub" | "mul" + | "div" | "mod" | "and" | "or" | "xor" + | "lsl" | "lsr" | "concat" + | "checked_abs" | "checked_neg" | "checked_add" + | "checked_sub" | "checked_mul" | "compare"), _), + stack -> + fail (Bad_stack (loc, 2, Stack_ty stack)) + (* Generic parsing errors *) + | Prim (loc, prim, _), _ -> + fail @@ Invalid_primitive (loc, Instr, prim) + | (Int (loc, _) | String (loc, _)), _ -> + fail @@ Invalid_expression_kind loc and parse_contract : type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t -> @@ -1647,6 +1641,48 @@ let type_map_enc = (list Script.expr_encoding) (list Script.expr_encoding))) +let type_map descr = + let rec unparse_stack + : type a. a stack_ty -> Script.expr list + = function + | Empty_t -> [] + | Item_t (ty, rest) -> unparse_ty ty :: unparse_stack rest in + let rec type_map + : type bef aft. type_map -> (bef, aft) descr -> type_map + = fun acc { loc ; instr ; bef ; aft } -> + let self acc = + (loc, (unparse_stack bef, unparse_stack aft)) :: acc in + match instr with + | If_none (dbt, dbf) -> + let acc = type_map acc dbt in + let acc = type_map acc dbf in + self acc + | If_left (dbt, dbf) -> + let acc = type_map acc dbt in + let acc = type_map acc dbf in + self acc + | If_cons (dbt, dbf) -> + let acc = type_map acc dbt in + let acc = type_map acc dbf in + self acc + | Seq (dl, dr) -> + let acc = type_map acc dl in + let acc = type_map acc dr in + acc + | If (dbt, dbf) -> + let acc = type_map acc dbt in + let acc = type_map acc dbf in + self acc + | Loop body -> + let acc = type_map acc body in + self acc + | Dip body -> + let acc = type_map acc body in + self acc + | _ -> + self acc in + type_map [] descr + let typecheck_code : context -> Script.code -> type_map tzresult Lwt.t = fun ctxt { code; arg_type; ret_type; storage_type } -> @@ -1655,16 +1691,9 @@ let typecheck_code parse_ty storage_type >>=? fun (Ex storage_type) -> let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in - let result = ref [] in - let log loc (Stack_ty before, Stack_ty after) = - let rec unparse_stack - : type a. a stack_ty -> Script.expr list - = function - | Empty_t -> [] - | Item_t (ty, rest) -> unparse_ty ty :: unparse_stack rest in - result := (loc, (unparse_stack before, unparse_stack after)) :: !result in - parse_lambda ctxt ~log ~storage_type arg_type_full ret_type_full code >>=? fun _ -> - return !result + parse_lambda ctxt ~storage_type arg_type_full ret_type_full code + >>=? fun (Lam (descr,_)) -> + return (type_map descr) let typecheck_tagged_data : context -> Script.expr -> unit tzresult Lwt.t diff --git a/src/proto/bootstrap/script_typed_ir.ml b/src/proto/bootstrap/script_typed_ir.ml index 2617a6d59..864372364 100644 --- a/src/proto/bootstrap/script_typed_ir.ml +++ b/src/proto/bootstrap/script_typed_ir.ml @@ -53,7 +53,7 @@ and ('a, 'b) union = L of 'a | R of 'b and end_of_stack = unit and ('arg, 'ret) lambda = - Lam of ('arg * end_of_stack, 'ret * end_of_stack) instr * Script.expr + Lam of ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.expr and ('arg, 'ret) typed_contract = 'arg ty * 'ret ty * Contract.t @@ -76,6 +76,10 @@ and 'ty ty = | Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty | Contract_t : 'arg ty * 'ret ty -> ('arg, 'ret) typed_contract ty +and 'ty stack_ty = + | Item_t : 'ty ty * 'rest stack_ty -> ('ty * 'rest) stack_ty + | Empty_t : end_of_stack stack_ty + (* ---- Instructions --------------------------------------------------------*) (* The low-level, typed instructions, as a GADT whose parameters @@ -107,21 +111,21 @@ and ('bef, 'aft) instr = ('v * 'rest, 'v option * 'rest) instr | Cons_none : 'a ty -> ('rest, 'a option * 'rest) instr - | If_none : ('bef, 'aft) instr * ('a * 'bef, 'aft) instr -> + | If_none : ('bef, 'aft) descr * ('a * 'bef, 'aft) descr -> ('a option * 'bef, 'aft) instr (* unions *) | Left : ('l * 'rest, (('l, 'r) union * 'rest)) instr | Right : ('r * 'rest, (('l, 'r) union * 'rest)) instr - | If_left : ('l * 'bef, 'aft) instr * ('r * 'bef, 'aft) instr -> + | If_left : ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr -> (('l, 'r) union * 'bef, 'aft) instr (* lists *) | Cons_list : ('a * ('a list * 'rest), ('a list * 'rest)) instr | Nil : ('rest, ('a list * 'rest)) instr - | If_cons : ('a * ('a list * 'bef), 'aft) instr * ('bef, 'aft) instr -> + | If_cons : ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr -> ('a list * 'bef, 'aft) instr | List_map : (('param, 'ret) lambda * ('param list * 'rest), 'ret list * 'rest) instr @@ -158,9 +162,9 @@ and ('bef, 'aft) instr = | Concat : (string * (string * 'rest), string * 'rest) instr (* timestamp operations *) - | Add_seconds_to_timestamp : (unsigned, 'l) int_kind * Script.location -> + | Add_seconds_to_timestamp : (unsigned, 'l) int_kind -> ((unsigned, 'l) int_val * (Timestamp.t * 'rest), Timestamp.t * 'rest) instr - | Add_timestamp_to_seconds : (unsigned, 'l) int_kind * Script.location -> + | Add_timestamp_to_seconds : (unsigned, 'l) int_kind -> (Timestamp.t * ((unsigned, 'l) int_val * 'rest), Timestamp.t * 'rest) instr (* currency operations *) | Add_tez : @@ -181,15 +185,15 @@ and ('bef, 'aft) instr = | Not : (bool * 'rest, bool * 'rest) instr (* integer operations *) - | Checked_neg_int : (signed, 'l) int_kind * Script.location -> + | Checked_neg_int : (signed, 'l) int_kind -> ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr - | Checked_abs_int : (signed, 'l) int_kind * Script.location -> + | Checked_abs_int : (signed, 'l) int_kind -> ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr - | Checked_add_int : ('s, 'l) int_kind * Script.location -> + | Checked_add_int : ('s, 'l) int_kind -> (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr - | Checked_sub_int : ('s, 'l) int_kind * Script.location -> + | Checked_sub_int : ('s, 'l) int_kind -> (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr - | Checked_mul_int : ('s, 'l) int_kind * Script.location -> + | Checked_mul_int : ('s, 'l) int_kind -> (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr | Neg_int : (signed, 'l) int_kind -> ((signed, 'l) int_val * 'rest, (signed, 'l) int_val * 'rest) instr @@ -201,9 +205,9 @@ and ('bef, 'aft) instr = (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr | Mul_int : ('s, 'l) int_kind -> (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr - | Div_int : ('s, 'l) int_kind * Script.location -> + | Div_int : ('s, 'l) int_kind -> (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr - | Mod_int : ('s, 'l) int_kind * Script.location -> + | Mod_int : ('s, 'l) int_kind -> (('s, 'l) int_val * (('s, 'l) int_val * 'rest), ('s, 'l) int_val * 'rest) instr | Lsl_int : (unsigned, 'l) int_kind -> ((unsigned, 'l) int_val * ((unsigned, eight) int_val * 'rest), (unsigned, 'l) int_val * 'rest) instr @@ -218,19 +222,19 @@ and ('bef, 'aft) instr = | Not_int : (unsigned, 'l) int_kind -> ((unsigned, 'l) int_val * 'rest, (unsigned, 'l) int_val * 'rest) instr (* control *) - | Seq : ('bef, 'trans) instr * ('trans, 'aft) instr -> + | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> ('bef, 'aft) instr - | If : ('bef, 'aft) instr * ('bef, 'aft) instr -> + | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> (bool * 'bef, 'aft) instr - | Loop : ('rest, bool * 'rest) instr -> + | Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr - | Dip : ('bef, 'aft) instr -> + | Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr - | Fail : Script.location -> + | Fail : ('bef, 'aft) instr | Nop : ('rest, 'rest) instr @@ -253,12 +257,12 @@ and ('bef, 'aft) instr = (* casts *) | Int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind -> (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr - | Checked_int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind * Script.location -> + | Checked_int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind -> (('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr (* protocol *) | Manager : (('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr - | Transfer_tokens : 'sto ty * Script.location -> + | Transfer_tokens : 'sto ty -> ('arg * (Tez.t * (('arg, 'ret) typed_contract * ('sto * end_of_stack))), 'ret * ('sto * end_of_stack)) instr | Create_account : (public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))), @@ -281,3 +285,9 @@ and ('bef, 'aft) instr = ('rest, ('p, 'r) typed_contract * 'rest) instr | Amount : ('rest, Tez.t * 'rest) instr + +and ('bef, 'aft) descr = + { loc : Script.location ; + bef : 'bef stack_ty ; + aft : 'aft stack_ty ; + instr : ('bef, 'aft) instr } diff --git a/src/proto/bootstrap/services.ml b/src/proto/bootstrap/services.ml index 2b07c8baa..86c3c79a1 100644 --- a/src/proto/bootstrap/services.ml +++ b/src/proto/bootstrap/services.ml @@ -327,21 +327,40 @@ module Helpers = struct obj1 (req "timestamp" Timestamp.encoding)) RPC.Path.(custom_root / "helpers" / "minimal_timestamp") + let run_code_input_encoding = + (obj5 + (req "script" Script.code_encoding) + (req "storage" Script.expr_encoding) + (req "input" Script.expr_encoding) + (opt "amount" Tez.encoding) + (opt "contract" Contract.encoding)) + let run_code custom_root = RPC.service ~description: "Run a piece of code in the current context" - ~input: (obj5 - (req "script" Script.code_encoding) - (req "storage" Script.expr_encoding) - (req "input" Script.expr_encoding) - (opt "amount" Tez.encoding) - (opt "contract" Contract.encoding)) + ~input: run_code_input_encoding ~output: (wrap_tzerror (obj2 (req "storage" Script.expr_encoding) (req "output" Script.expr_encoding))) RPC.Path.(custom_root / "helpers" / "run_code") + let trace_code custom_root = + RPC.service + ~description: "Run a piece of code in the current context, \ + keeping a trace" + ~input: run_code_input_encoding + ~output: (wrap_tzerror + (obj3 + (req "storage" Script.expr_encoding) + (req "output" Script.expr_encoding) + (req "trace" + (list @@ obj3 + (req "location" Script.location_encoding) + (req "gas" int31) + (req "stack" (list (Script.expr_encoding))))))) + RPC.Path.(custom_root / "helpers" / "trace_code") + let typecheck_code custom_root = RPC.service ~description: "Typecheck a piece of code in the current context" diff --git a/src/proto/bootstrap/services_registration.ml b/src/proto/bootstrap/services_registration.ml index 3045561ce..653a0656c 100644 --- a/src/proto/bootstrap/services_registration.ml +++ b/src/proto/bootstrap/services_registration.ml @@ -180,31 +180,45 @@ let minimal_timestamp ctxt prio = let () = register1 Services.Helpers.minimal_timestamp minimal_timestamp let () = + let run_parameters ctxt (script, storage, input, amount, contract) = + let amount = + match amount with + | Some amount -> amount + | None -> + match Tez.of_cents 100_00L with + | Some tez -> tez + | None -> Tez.zero in + let contract = + match contract with + | Some contract -> contract + | None -> + Contract.default_contract + (List.hd Bootstrap.accounts).Bootstrap.public_key_hash in + let storage : Script.storage = + { storage ; storage_type = (script : Script.code).storage_type } in + let qta = + Constants.instructions_per_transaction ctxt in + (script, storage, input, amount, contract, qta) in register1 Services.Helpers.run_code - (fun ctxt (script, storage, input, amount, contract) -> - let amount = - match amount with - | Some amount -> amount - | None -> - match Tez.of_cents 100_00L with - | Some tez -> tez - | None -> Tez.zero in - let contract = - match contract with - | Some contract -> contract - | None -> - Contract.default_contract - (List.hd Bootstrap.accounts).Bootstrap.public_key_hash in - let storage = - { Script.storage ; storage_type = script.storage_type } in - let qta = - Constants.instructions_per_transaction ctxt in + (fun ctxt parameters -> + let (script, storage, input, amount, contract, qta) = + run_parameters ctxt parameters in Script_interpreter.execute contract (* transaction initiator *) contract (* script owner *) ctxt storage script amount input qta >>=? fun (sto, ret, _qta, _ctxt) -> - Error_monad.return (sto, ret)) + Error_monad.return (sto, ret)) ; + register1 Services.Helpers.trace_code + (fun ctxt parameters -> + let (script, storage, input, amount, contract, qta) = + run_parameters ctxt parameters in + Script_interpreter.trace + contract (* transaction initiator *) + contract (* script owner *) + ctxt storage script amount input + qta >>=? fun ((sto, ret, _qta, _ctxt), trace) -> + Error_monad.return (sto, ret, trace)) let () = register1 Services.Helpers.typecheck_code