diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 435d9920e..61290bebc 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -65,6 +65,13 @@ module Script_timestamp = struct Raw_context.current_timestamp ctxt |> Timestamp.to_seconds |> of_int64 + + let set_now ctxt timestamp = + timestamp + |> to_zint + |> Z.to_int64 + |> Time.of_seconds + |> (Raw_context.set_current_timestamp ctxt) end module Script = struct include Michelson_v1_primitives diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index f18be37ef..34933a848 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -178,6 +178,7 @@ module Script_timestamp : sig val add_delta: t -> z num -> t val sub_delta: t -> z num -> t val now: context -> t + val set_now: context -> t -> context val to_zint: t -> Z.t val of_zint: Z.t -> t end @@ -248,6 +249,7 @@ module Script : sig | I_NEQ | I_NIL | I_NONE + | I_NOP | I_NOT | I_NOW | I_OR diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 29c2db441..bfd885fff 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -93,6 +93,7 @@ type prim = | I_NEQ | I_NIL | I_NONE + | I_NOP | I_NOT | I_NOW | I_OR @@ -226,6 +227,7 @@ let string_of_prim = function | I_NEQ -> "NEQ" | I_NIL -> "NIL" | I_NONE -> "NONE" + | I_NOP -> "NOP" | I_NOT -> "NOT" | I_NOW -> "NOW" | I_OR -> "OR" @@ -340,6 +342,7 @@ let prim_of_string = function | "NEQ" -> ok I_NEQ | "NIL" -> ok I_NIL | "NONE" -> ok I_NONE + | "NOP" -> ok I_NOP | "NOT" -> ok I_NOT | "NOW" -> ok I_NOW | "OR" -> ok I_OR diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli index c51e8b443..6b402d8a9 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli @@ -91,6 +91,7 @@ type prim = | I_NEQ | I_NIL | I_NONE + | I_NOP | I_NOT | I_NOW | I_OR diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 257fd0819..51b0a8dac 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -51,6 +51,7 @@ type root_context = t let current_level ctxt = ctxt.level let current_timestamp ctxt = ctxt.timestamp +let set_current_timestamp ctxt timestamp = { ctxt with timestamp } let current_fitness ctxt = ctxt.fitness let first_level ctxt = ctxt.first_level let constants ctxt = ctxt.constants diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index 940d00abc..f656f0eda 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -80,6 +80,7 @@ val recover: context -> Context.t val current_level: context -> Level_repr.t val current_timestamp: context -> Time.t +val set_current_timestamp: context -> Time.t -> context val current_fitness: context -> Int64.t val set_current_fitness: context -> Int64.t -> t diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 5229e542f..3d20eebc4 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -159,7 +159,682 @@ let unparse_stack ctxt (stack, stack_ty) = module Interp_costs = Michelson_v1_gas.Cost_of -let rec interp +type ex_descr_stack = Ex_descr_stack : (('a, 'b) descr * 'a stack) -> ex_descr_stack + +let rec step + : type b a. + (?log: execution_trace ref -> + context -> + source: Contract.t -> + self: Contract.t -> + payer: Contract.t -> + ?visitor: (ex_descr_stack -> unit) -> + Tez.t -> + (b, a) descr -> b stack -> + (a stack * context) tzresult Lwt.t) = + fun ?log ctxt ~source ~self ~payer ?visitor amount ({ instr ; loc ; _ } as descr) stack -> + Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> + (match visitor with + | Some visitor -> visitor @@ Ex_descr_stack(descr, stack) + | None -> ()) ; + let step_same ctxt = step ?log ctxt ~source ~self ~payer ?visitor amount in + let logged_return : type a b. + (b, a) descr -> + a stack * context -> + (a stack * context) tzresult Lwt.t = + fun descr (ret, ctxt) -> + match log with + | None -> return (ret, ctxt) + | Some log -> + trace + Cannot_serialize_log + (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> + log := (descr.loc, Gas.level ctxt, stack) :: !log ; + return (ret, ctxt) in + let get_log (log : execution_trace ref option) = + Option.map ~f:(fun l -> List.rev !l) log in + let consume_gas_terop : type ret arg1 arg2 arg3 rest. + (_ * (_ * (_ * rest)), ret * rest) descr -> + ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> + (arg1 -> arg2 -> arg3 -> Gas.cost) -> + rest stack -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2, x3) cost_func rest -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2 x3, rest), ctxt) in + let consume_gas_binop : type ret arg1 arg2 rest. + (_ * (_ * rest), ret * rest) descr -> + ((arg1 -> arg2 -> ret) * arg1 * arg2) -> + (arg1 -> arg2 -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, x1, x2) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (op x1 x2, rest), ctxt) in + let consume_gas_unop : type ret arg rest. + (_ * rest, ret * rest) descr -> + ((arg -> ret) * arg) -> + (arg -> Gas.cost) -> + rest stack -> + context -> + ((ret * rest) stack * context) tzresult Lwt.t = + fun descr (op, arg) cost_func rest ctxt -> + Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> + logged_return descr (Item (op arg, rest), ctxt) in + let consume_gaz_comparison : + type t rest. + (t * (t * rest), Script_int.z Script_int.num * rest) descr -> + (t -> t -> int) -> + (t -> t -> Gas.cost) -> + t -> t -> + rest stack -> + ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = + fun descr op cost x1 x2 rest -> + Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> + logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in + let logged_return : + a stack * context -> + (a stack * context) tzresult Lwt.t = + logged_return descr in + match instr, stack with + (* stack ops *) + | Drop, Item (_, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (rest, ctxt) + | Dup, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (v, Item (v, rest)), ctxt) + | Swap, Item (vi, Item (vo, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + logged_return (Item (vo, Item (vi, rest)), ctxt) + | Const v, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + (* options *) + | Cons_some, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (Some v, rest), ctxt) + | Cons_none _, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | If_none (bt, _), Item (None, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt rest + | If_none (_, bf), Item (Some v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf (Item (v, rest)) + (* pairs *) + | Cons_pair, Item (a, Item (b, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> + logged_return (Item ((a, b), rest), ctxt) + | Car, Item ((a, _), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (a, rest), ctxt) + | Cdr, Item ((_, b), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> + logged_return (Item (b, rest), ctxt) + (* unions *) + | Left, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (L v, rest), ctxt) + | Right, Item (v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> + logged_return (Item (R v, rest), ctxt) + | If_left (bt, _), Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt (Item (v, rest)) + | If_left (_, bf), Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf (Item (v, rest)) + (* lists *) + | Cons_list, Item (hd, Item (tl, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> + logged_return (Item (hd :: tl, rest), ctxt) + | Nil, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> + logged_return (Item ([], rest), ctxt) + | If_cons (_, bf), Item ([], rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf rest + | If_cons (bt, _), Item (hd :: tl, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt (Item (hd, Item (tl, rest))) + | List_map body, Item (l, rest) -> + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (Item (List.rev acc, rest), ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (hd :: acc) + in loop rest ctxt l [] >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | List_size, Item (list, rest) -> + Lwt.return + (List.fold_left + (fun acc _ -> + acc >>? fun (size, ctxt) -> + Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> + ok (size + 1 (* FIXME: overflow *), ctxt)) + (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> + logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) + | List_iter body, Item (l, init) -> + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + (* sets *) + | Empty_set t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> + logged_return (Item (empty_set t, rest), ctxt) + | Set_iter body, Item (set, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> + let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Set_mem, Item (v, Item (set, rest)) -> + consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt + | Set_update, Item (v, Item (presence, Item (set, rest))) -> + consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest + | Set_size, Item (set, rest) -> + consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt + (* maps *) + | Empty_map (t, _), rest -> + Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> + logged_return (Item (empty_map t, rest), ctxt) + | Map_map body, Item (map, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop rest ctxt l acc = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (acc, ctxt) + | (k, _) as hd :: tl -> + step_same ctxt body (Item (hd, rest)) + >>=? fun (Item (hd, rest), ctxt) -> + loop rest ctxt tl (map_update k (Some hd) acc) + in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Map_iter body, Item (map, init) -> + Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> + let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in + let rec loop ctxt l stack = + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + match l with + | [] -> return (stack, ctxt) + | hd :: tl -> + step_same ctxt body (Item (hd, stack)) + >>=? fun (stack, ctxt) -> + loop ctxt tl stack + in loop ctxt l init >>=? fun (res, ctxt) -> + logged_return (res, ctxt) + | Map_mem, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt + | Map_get, Item (v, Item (map, rest)) -> + consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt + | Map_update, Item (k, Item (v, Item (map, rest))) -> + consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest + | Map_size, Item (map, rest) -> + consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt + (* Big map operations *) + | Big_map_mem, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> + Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_get, Item (key, Item (map, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> + Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> + consume_gas_terop descr + (Script_ir_translator.big_map_update, key, maybe_value, map) + Interp_costs.big_map_update rest + (* timestamp operations *) + | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> + consume_gas_binop descr + (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> + consume_gas_binop descr (Script_timestamp.add_delta, t, n) + Interp_costs.add_timestamp rest ctxt + | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> + consume_gas_binop descr (Script_timestamp.sub_delta, t, s) + Interp_costs.sub_timestamp rest ctxt + | Diff_timestamps, Item (t1, Item (t2, rest)) -> + consume_gas_binop descr (Script_timestamp.diff, t1, t2) + Interp_costs.diff_timestamps rest ctxt + (* string operations *) + | Concat_string_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> + let s = String.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_string, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> + let s = String.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_string, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (String.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | String_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) + (* bytes operations *) + | Concat_bytes_pair, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> + let s = MBytes.concat "" [x; y] in + logged_return (Item (s, rest), ctxt) + | Concat_bytes, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> + let s = MBytes.concat "" ss in + logged_return (Item (s, rest), ctxt) + | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> + let s_length = Z.of_int (MBytes.length s) in + let offset = Script_int.to_zint offset in + let length = Script_int.to_zint length in + if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> + logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) + else + Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Bytes_size, Item (s, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) + (* currency operations *) + | Add_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x +? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Sub_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return Tez.(x -? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + | Mul_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + | Mul_nattez, Item (y, Item (x, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> + begin + match Script_int.to_int64 y with + | None -> fail (Overflow (loc, get_log log)) + | Some y -> + Lwt.return Tez.(x *? y) >>=? fun res -> + logged_return (Item (res, rest), ctxt) + end + (* boolean operations *) + | Or, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt + | And, Item (x, Item (y, rest)) -> + consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt + | Xor, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt + | Not, Item (x, rest) -> + consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt + (* integer operations *) + | Is_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt + | Abs_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt + | Int_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt + | Neg_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Neg_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt + | Add_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt + | Add_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt + | Sub_int, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt + | Mul_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt + | Mul_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt + | Ediv_teznat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.of_int64 (Tez.to_mutez x) in + consume_gas_binop descr + ((fun x y -> + match Script_int.ediv x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 q, + Script_int.to_int64 r with + | Some q, Some r -> + begin + match Tez.of_mutez q, Tez.of_mutez r with + | Some q, Some r -> Some (q,r) + (* Cannot overflow *) + | _ -> assert false + end + (* Cannot overflow *) + | _ -> assert false), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_tez, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> + let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in + let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in + consume_gas_binop descr + ((fun x y -> match Script_int.ediv_n x y with + | None -> None + | Some (q, r) -> + match Script_int.to_int64 r with + | None -> assert false (* Cannot overflow *) + | Some r -> + match Tez.of_mutez r with + | None -> assert false (* Cannot overflow *) + | Some r -> Some (q, r)), + x, y) + Interp_costs.div + rest + ctxt + | Ediv_intint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_intnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natint, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt + | Ediv_natnat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt + | Lsl_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> + begin + match Script_int.shift_left_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some x -> logged_return (Item (x, rest), ctxt) + end + | Lsr_nat, Item (x, Item (y, rest)) -> + Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> + begin + match Script_int.shift_right_n x y with + | None -> fail (Overflow (loc, get_log log)) + | Some r -> logged_return (Item (r, rest), ctxt) + end + | Or_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt + | And_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | And_int_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt + | Xor_nat, Item (x, Item (y, rest)) -> + consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt + | Not_int, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + | Not_nat, Item (x, rest) -> + consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt + (* control *) + | Seq (hd, tl), stack -> + step_same ctxt hd stack >>=? fun (trans, ctxt) -> + step_same ctxt tl trans + | If (bt, _), Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bt rest + | If (_, bf), Item (false, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> + step_same ctxt bf rest + | Loop body, Item (true, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step_same ctxt body rest >>=? fun (trans, ctxt) -> + step_same ctxt descr trans + | Loop _, Item (false, rest) -> + logged_return (rest, ctxt) + | Loop_left body, Item (L v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + step_same ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> + step_same ctxt descr trans + | Loop_left _, Item (R v, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> + logged_return (Item (v, rest), ctxt) + | Dip b, Item (ign, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> + step_same ctxt b rest >>=? fun (res, ctxt) -> + logged_return (Item (ign, res), ctxt) + | Exec, Item (arg, Item (lam, rest)) -> + Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> + interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> + logged_return (Item (res, rest), ctxt) + | Lambda lam, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> + logged_return (Item (lam, rest), ctxt) + | Failwith tv, Item (v, _) -> + trace Cannot_serialize_failure + (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + fail (Reject (loc, v, get_log log)) + | Nop, stack -> + logged_return (stack, ctxt) + (* comparison *) + | Compare (Bool_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest + | Compare (String_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest + | Compare (Bytes_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest + | Compare (Mutez_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest + | Compare (Int_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest + | Compare (Nat_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest + | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Signature.Public_key_hash.compare + Interp_costs.compare_key_hash a b rest + | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest + | Compare (Address_key _), Item (a, Item (b, rest)) -> + consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest + (* comparators *) + | Eq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Neq, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Lt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Le, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Gt, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + | Ge, Item (cmpres, rest) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> + logged_return (Item (cmpres, rest), ctxt) + (* packing *) + | Pack t, Item (value, rest) -> + Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> + logged_return (Item (bytes, rest), ctxt) + | Unpack t, Item (bytes, rest) -> + Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> + if Compare.Int.(MBytes.length bytes >= 1) && + Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then + let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + | Some expr -> + Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> + parse_data ctxt t (Micheline.root expr) >>= function + | Ok (value, ctxt) -> + logged_return (Item (Some value, rest), ctxt) + | Error _ignored -> + Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> + logged_return (Item (None, rest), ctxt) + else + logged_return (Item (None, rest), ctxt) + (* protocol *) + | Address, Item ((_, contract), rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> + logged_return (Item (contract, rest), ctxt) + | Contract t, Item (contract, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> + Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> + logged_return (Item (maybe_contract, rest), ctxt) + | Transfer_tokens, + Item (p, Item (amount, Item ((tp, destination), rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> + unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> + let operation = + Transaction + { amount ; destination ; + parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + | Create_account, + Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; manager ; delegate ; preorigination = Some contract ; + delegatable ; script = None ; spendable = true } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, + Item (contract, rest)), ctxt) + | Implicit_account, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> + let contract = Contract.implicit_contract key in + logged_return (Item ((Unit_t None, contract), rest), ctxt) + | Create_contract (storage_type, param_type, Lam (_, code)), + Item (manager, Item + (delegate, Item + (spendable, Item + (delegatable, Item + (credit, Item + (init, rest)))))) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> + unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> + unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; + Prim (0, K_storage, [ unparsed_storage_type ], []) ; + Prim (0, K_code, [ Micheline.root code ], []) ])) in + unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> + let operation = + Origination + { credit ; manager ; delegate ; preorigination = Some contract ; + delegatable ; spendable ; + script = Some { code = Script.lazy_expr code ; + storage = Script.lazy_expr storage } } in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return + (Item (Internal_operation { source = self ; operation ; nonce }, + Item (contract, rest)), ctxt) + | Set_delegate, + Item (delegate, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> + let operation = Delegation delegate in + Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> + logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) + | Balance, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> + Contract.get_balance ctxt self >>=? fun balance -> + logged_return (Item (balance, rest), ctxt) + | Now, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> + let now = Script_timestamp.now ctxt in + logged_return (Item (now, rest), ctxt) + | Check_signature, Item (key, Item (signature, Item (message, rest))) -> + Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> + let res = Signature.check key signature message in + logged_return (Item (res, rest), ctxt) + | Hash_key, Item (key, rest) -> + Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> + logged_return (Item (Signature.Public_key.hash key, rest), ctxt) + | Blake2b, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + let hash = Raw_hashes.blake2b bytes in + logged_return (Item (hash, rest), ctxt) + | Sha256, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> + let hash = Raw_hashes.sha256 bytes in + logged_return (Item (hash, rest), ctxt) + | Sha512, Item (bytes, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> + let hash = Raw_hashes.sha512 bytes in + logged_return (Item (hash, rest), ctxt) + | Steps_to_quota, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> + let steps = match Gas.level ctxt with + | Limited { remaining } -> remaining + | Unaccounted -> Z.of_string "99999999" in + logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) + | Source, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item (payer, rest), ctxt) + | Sender, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> + logged_return (Item (source, rest), ctxt) + | Self t, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> + logged_return (Item ((t,self), rest), ctxt) + | Amount, rest -> + Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> + logged_return (Item (amount, rest), ctxt) + +and interp : type p r. (?log: execution_trace ref -> context -> @@ -167,667 +842,6 @@ let rec interp (p, r) lambda -> p -> (r * context) tzresult Lwt.t) = fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg -> - let rec step - : type b a. - context -> (b, a) descr -> b stack -> - (a stack * context) tzresult Lwt.t = - fun ctxt ({ instr ; loc ; _ } as descr) stack -> - Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt -> - let logged_return : type a b. - (b, a) descr -> - a stack * context -> - (a stack * context) tzresult Lwt.t = - fun descr (ret, ctxt) -> - match log with - | None -> return (ret, ctxt) - | Some log -> - trace - Cannot_serialize_log - (unparse_stack ctxt (ret, descr.aft)) >>=? fun stack -> - log := (descr.loc, Gas.level ctxt, stack) :: !log ; - return (ret, ctxt) in - let get_log (log : execution_trace ref option) = - Option.map ~f:(fun l -> List.rev !l) log in - let consume_gas_terop : type ret arg1 arg2 arg3 rest. - (_ * (_ * (_ * rest)), ret * rest) descr -> - ((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) -> - (arg1 -> arg2 -> arg3 -> Gas.cost) -> - rest stack -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2, x3) cost_func rest -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2 x3, rest), ctxt) in - let consume_gas_binop : type ret arg1 arg2 rest. - (_ * (_ * rest), ret * rest) descr -> - ((arg1 -> arg2 -> ret) * arg1 * arg2) -> - (arg1 -> arg2 -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, x1, x2) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (op x1 x2, rest), ctxt) in - let consume_gas_unop : type ret arg rest. - (_ * rest, ret * rest) descr -> - ((arg -> ret) * arg) -> - (arg -> Gas.cost) -> - rest stack -> - context -> - ((ret * rest) stack * context) tzresult Lwt.t = - fun descr (op, arg) cost_func rest ctxt -> - Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt -> - logged_return descr (Item (op arg, rest), ctxt) in - let consume_gaz_comparison : - type t rest. - (t * (t * rest), Script_int.z Script_int.num * rest) descr -> - (t -> t -> int) -> - (t -> t -> Gas.cost) -> - t -> t -> - rest stack -> - ((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t = - fun descr op cost x1 x2 rest -> - Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt -> - logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in - let logged_return : - a stack * context -> - (a stack * context) tzresult Lwt.t = - logged_return descr in - match instr, stack with - (* stack ops *) - | Drop, Item (_, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (rest, ctxt) - | Dup, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (v, Item (v, rest)), ctxt) - | Swap, Item (vi, Item (vo, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - logged_return (Item (vo, Item (vi, rest)), ctxt) - | Const v, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - (* options *) - | Cons_some, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (Some v, rest), ctxt) - | Cons_none _, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | If_none (bt, _), Item (None, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt rest - | If_none (_, bf), Item (Some v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf (Item (v, rest)) - (* pairs *) - | Cons_pair, Item (a, Item (b, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt -> - logged_return (Item ((a, b), rest), ctxt) - | Car, Item ((a, _), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (a, rest), ctxt) - | Cdr, Item ((_, b), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt -> - logged_return (Item (b, rest), ctxt) - (* unions *) - | Left, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (L v, rest), ctxt) - | Right, Item (v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt -> - logged_return (Item (R v, rest), ctxt) - | If_left (bt, _), Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt (Item (v, rest)) - | If_left (_, bf), Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf (Item (v, rest)) - (* lists *) - | Cons_list, Item (hd, Item (tl, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt -> - logged_return (Item (hd :: tl, rest), ctxt) - | Nil, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt -> - logged_return (Item ([], rest), ctxt) - | If_cons (_, bf), Item ([], rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf rest - | If_cons (bt, _), Item (hd :: tl, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt (Item (hd, Item (tl, rest))) - | List_map body, Item (l, rest) -> - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (Item (List.rev acc, rest), ctxt) - | hd :: tl -> - step ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (hd :: acc) - in loop rest ctxt l [] >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | List_size, Item (list, rest) -> - Lwt.return - (List.fold_left - (fun acc _ -> - acc >>? fun (size, ctxt) -> - Gas.consume ctxt Interp_costs.list_size >>? fun ctxt -> - ok (size + 1 (* FIXME: overflow *), ctxt)) - (ok (0, ctxt)) list) >>=? fun (len, ctxt) -> - logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt) - | List_iter body, Item (l, init) -> - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - (* sets *) - | Empty_set t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt -> - logged_return (Item (empty_set t, rest), ctxt) - | Set_iter body, Item (set, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt -> - let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Set_mem, Item (v, Item (set, rest)) -> - consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt - | Set_update, Item (v, Item (presence, Item (set, rest))) -> - consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest - | Set_size, Item (set, rest) -> - consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt - (* maps *) - | Empty_map (t, _), rest -> - Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt -> - logged_return (Item (empty_map t, rest), ctxt) - | Map_map body, Item (map, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop rest ctxt l acc = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (acc, ctxt) - | (k, _) as hd :: tl -> - step ctxt body (Item (hd, rest)) - >>=? fun (Item (hd, rest), ctxt) -> - loop rest ctxt tl (map_update k (Some hd) acc) - in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Map_iter body, Item (map, init) -> - Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt -> - let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in - let rec loop ctxt l stack = - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - match l with - | [] -> return (stack, ctxt) - | hd :: tl -> - step ctxt body (Item (hd, stack)) - >>=? fun (stack, ctxt) -> - loop ctxt tl stack - in loop ctxt l init >>=? fun (res, ctxt) -> - logged_return (res, ctxt) - | Map_mem, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt - | Map_get, Item (v, Item (map, rest)) -> - consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt - | Map_update, Item (k, Item (v, Item (map, rest))) -> - consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest - | Map_size, Item (map, rest) -> - consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt - (* Big map operations *) - | Big_map_mem, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_get, Item (key, Item (map, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt -> - Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) -> - consume_gas_terop descr - (Script_ir_translator.big_map_update, key, maybe_value, map) - Interp_costs.big_map_update rest - (* timestamp operations *) - | Add_seconds_to_timestamp, Item (n, Item (t, rest)) -> - consume_gas_binop descr - (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Add_timestamp_to_seconds, Item (t, Item (n, rest)) -> - consume_gas_binop descr (Script_timestamp.add_delta, t, n) - Interp_costs.add_timestamp rest ctxt - | Sub_timestamp_seconds, Item (t, Item (s, rest)) -> - consume_gas_binop descr (Script_timestamp.sub_delta, t, s) - Interp_costs.sub_timestamp rest ctxt - | Diff_timestamps, Item (t1, Item (t2, rest)) -> - consume_gas_binop descr (Script_timestamp.diff, t1, t2) - Interp_costs.diff_timestamps rest ctxt - (* string operations *) - | Concat_string_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt -> - let s = String.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_string, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> - let s = String.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_string, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (String.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | String_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt) - (* bytes operations *) - | Concat_bytes_pair, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt -> - let s = MBytes.concat "" [x; y] in - logged_return (Item (s, rest), ctxt) - | Concat_bytes, Item (ss, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt -> - let s = MBytes.concat "" ss in - logged_return (Item (s, rest), ctxt) - | Slice_bytes, Item (offset, Item (length, Item (s, rest))) -> - let s_length = Z.of_int (MBytes.length s) in - let offset = Script_int.to_zint offset in - let length = Script_int.to_zint length in - if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt -> - logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt) - else - Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Bytes_size, Item (s, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt) - (* currency operations *) - | Add_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x +? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Sub_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return Tez.(x -? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - | Mul_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - | Mul_nattez, Item (y, Item (x, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt -> - begin - match Script_int.to_int64 y with - | None -> fail (Overflow (loc, get_log log)) - | Some y -> - Lwt.return Tez.(x *? y) >>=? fun res -> - logged_return (Item (res, rest), ctxt) - end - (* boolean operations *) - | Or, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt - | And, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt - | Xor, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt - | Not, Item (x, rest) -> - consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt - (* integer operations *) - | Is_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt - | Abs_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt - | Int_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt - | Neg_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Neg_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt - | Add_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt - | Add_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt - | Sub_int, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt - | Mul_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt - | Mul_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt - | Ediv_teznat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - let x = Script_int.of_int64 (Tez.to_mutez x) in - consume_gas_binop descr - ((fun x y -> - match Script_int.ediv x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 q, - Script_int.to_int64 r with - | Some q, Some r -> - begin - match Tez.of_mutez q, Tez.of_mutez r with - | Some q, Some r -> Some (q,r) - (* Cannot overflow *) - | _ -> assert false - end - (* Cannot overflow *) - | _ -> assert false), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_tez, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt -> - let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in - let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in - consume_gas_binop descr - ((fun x y -> match Script_int.ediv_n x y with - | None -> None - | Some (q, r) -> - match Script_int.to_int64 r with - | None -> assert false (* Cannot overflow *) - | Some r -> - match Tez.of_mutez r with - | None -> assert false (* Cannot overflow *) - | Some r -> Some (q, r)), - x, y) - Interp_costs.div - rest - ctxt - | Ediv_intint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_intnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natint, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt - | Ediv_natnat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt - | Lsl_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt -> - begin - match Script_int.shift_left_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some x -> logged_return (Item (x, rest), ctxt) - end - | Lsr_nat, Item (x, Item (y, rest)) -> - Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt -> - begin - match Script_int.shift_right_n x y with - | None -> fail (Overflow (loc, get_log log)) - | Some r -> logged_return (Item (r, rest), ctxt) - end - | Or_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt - | And_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | And_int_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt - | Xor_nat, Item (x, Item (y, rest)) -> - consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt - | Not_int, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - | Not_nat, Item (x, rest) -> - consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt - (* control *) - | Seq (hd, tl), stack -> - step ctxt hd stack >>=? fun (trans, ctxt) -> - step ctxt tl trans - | If (bt, _), Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bt rest - | If (_, bf), Item (false, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt -> - step ctxt bf rest - | Loop body, Item (true, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ctxt body rest >>=? fun (trans, ctxt) -> - step ctxt descr trans - | Loop _, Item (false, rest) -> - logged_return (rest, ctxt) - | Loop_left body, Item (L v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - step ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) -> - step ctxt descr trans - | Loop_left _, Item (R v, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt -> - logged_return (Item (v, rest), ctxt) - | Dip b, Item (ign, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt -> - step ctxt b rest >>=? fun (res, ctxt) -> - logged_return (Item (ign, res), ctxt) - | Exec, Item (arg, Item (lam, rest)) -> - Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt -> - interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) -> - logged_return (Item (res, rest), ctxt) - | Lambda lam, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt -> - logged_return (Item (lam, rest), ctxt) - | Failwith tv, Item (v, _) -> - trace Cannot_serialize_failure - (unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - fail (Reject (loc, v, get_log log)) - | Nop, stack -> - logged_return (stack, ctxt) - (* comparison *) - | Compare (Bool_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest - | Compare (String_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest - | Compare (Bytes_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest - | Compare (Mutez_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest - | Compare (Int_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest - | Compare (Nat_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest - | Compare (Key_hash_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Signature.Public_key_hash.compare - Interp_costs.compare_key_hash a b rest - | Compare (Timestamp_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest - | Compare (Address_key _), Item (a, Item (b, rest)) -> - consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest - (* comparators *) - | Eq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres = 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Neq, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <> 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Lt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres < 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Le, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Gt, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres > 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - | Ge, Item (cmpres, rest) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres >= 0) in - Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt -> - logged_return (Item (cmpres, rest), ctxt) - (* packing *) - | Pack t, Item (value, rest) -> - Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) -> - logged_return (Item (bytes, rest), ctxt) - | Unpack t, Item (bytes, rest) -> - Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () -> - if Compare.Int.(MBytes.length bytes >= 1) && - Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then - let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - | Some expr -> - Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt -> - parse_data ctxt t (Micheline.root expr) >>= function - | Ok (value, ctxt) -> - logged_return (Item (Some value, rest), ctxt) - | Error _ignored -> - Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt -> - logged_return (Item (None, rest), ctxt) - else - logged_return (Item (None, rest), ctxt) - (* protocol *) - | Address, Item ((_, contract), rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt -> - logged_return (Item (contract, rest), ctxt) - | Contract t, Item (contract, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt -> - Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) -> - logged_return (Item (maybe_contract, rest), ctxt) - | Transfer_tokens, - Item (p, Item (amount, Item ((tp, destination), rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt -> - unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> - let operation = - Transaction - { amount ; destination ; - parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Create_account, - Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; script = None ; spendable = true } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Implicit_account, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt -> - let contract = Contract.implicit_contract key in - logged_return (Item ((Unit_t None, contract), rest), ctxt) - | Create_contract (storage_type, param_type, Lam (_, code)), - Item (manager, Item - (delegate, Item - (spendable, Item - (delegatable, Item - (credit, Item - (init, rest)))))) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> - unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) -> - unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) -> - let code = - Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ; - Prim (0, K_storage, [ unparsed_storage_type ], []) ; - Prim (0, K_code, [ Micheline.root code ], []) ])) in - unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> - let storage = Micheline.strip_locations storage in - Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) -> - let operation = - Origination - { credit ; manager ; delegate ; preorigination = Some contract ; - delegatable ; spendable ; - script = Some { code = Script.lazy_expr code ; - storage = Script.lazy_expr storage } } in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return - (Item (Internal_operation { source = self ; operation ; nonce }, - Item (contract, rest)), ctxt) - | Set_delegate, - Item (delegate, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt -> - let operation = Delegation delegate in - Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) -> - logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt) - | Balance, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt -> - Contract.get_balance ctxt self >>=? fun balance -> - logged_return (Item (balance, rest), ctxt) - | Now, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt -> - let now = Script_timestamp.now ctxt in - logged_return (Item (now, rest), ctxt) - | Check_signature, Item (key, Item (signature, Item (message, rest))) -> - Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt -> - let res = Signature.check key signature message in - logged_return (Item (res, rest), ctxt) - | Hash_key, Item (key, rest) -> - Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt -> - logged_return (Item (Signature.Public_key.hash key, rest), ctxt) - | Blake2b, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.blake2b bytes in - logged_return (Item (hash, rest), ctxt) - | Sha256, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt -> - let hash = Raw_hashes.sha256 bytes in - logged_return (Item (hash, rest), ctxt) - | Sha512, Item (bytes, rest) -> - Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt -> - let hash = Raw_hashes.sha512 bytes in - logged_return (Item (hash, rest), ctxt) - | Steps_to_quota, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt -> - let steps = match Gas.level ctxt with - | Limited { remaining } -> remaining - | Unaccounted -> Z.of_string "99999999" in - logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt) - | Source, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (payer, rest), ctxt) - | Sender, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt -> - logged_return (Item (source, rest), ctxt) - | Self t, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt -> - logged_return (Item ((t,self), rest), ctxt) - | Amount, rest -> - Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt -> - logged_return (Item (amount, rest), ctxt) in let stack = (Item (arg, Empty)) in begin match log with | None -> return_unit @@ -837,7 +851,7 @@ let rec interp log := (code.loc, Gas.level ctxt, stack) :: !log ; return_unit end >>=? fun () -> - step ctxt code stack >>=? fun (Item (ret, Empty), ctxt) -> + step ctxt ~source ~payer ~self amount code stack >>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt) (* ---- contract handling ---------------------------------------------------*) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index af616319b..8218a965b 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -61,3 +61,27 @@ val trace: parameter: Script.expr -> amount: Tez.t -> (execution_result * execution_trace) tzresult Lwt.t + +val interp: + (?log: execution_trace ref -> + context -> + source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t -> + ('p, 'r) Script_typed_ir.lambda -> 'p -> + ('r * context) tzresult Lwt.t) + +type 'tys stack = + | Item : 'ty * 'rest stack -> ('ty * 'rest) stack + | Empty : Script_typed_ir.end_of_stack stack + +type ex_descr_stack = Ex_descr_stack : (('a, 'b) Script_typed_ir.descr * 'a stack) -> ex_descr_stack + +val step: + ?log:execution_trace ref -> + context -> + source:Contract.t -> + self:Contract.t -> + payer:Contract.t -> + ?visitor: (ex_descr_stack -> unit) -> + Tez.t -> ('b, 'a) Script_typed_ir.descr + -> 'b stack + -> ('a stack * context) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d2e3d7b74..ad7f899e0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -36,6 +36,7 @@ module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty type ex_ty = Ex_ty : 'a ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty +type ex_typed_value = Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value type tc_context = | Lambda : tc_context @@ -322,6 +323,7 @@ let namespace = function | I_NIL | I_NONE | I_NOT + | I_NOP | I_NOW | I_OR | I_PAIR @@ -2968,150 +2970,173 @@ let typecheck_data (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) let rec unparse_data - : type a. context -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t - = fun ctxt mode ty a -> - Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> - match ty, a with - | Unit_t _, () -> - Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> - return (Prim (-1, D_Unit, [], []), ctxt) - | Int_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | Nat_t _, v -> - Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> - return (Int (-1, Script_int.to_zint v), ctxt) - | String_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> - return (String (-1, s), ctxt) - | Bytes_t _, s -> - Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> - return (Bytes (-1, s), ctxt) - | Bool_t _, true -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_True, [], []), ctxt) - | Bool_t _, false -> - Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_False, [], []), ctxt) - | Timestamp_t _, t -> - Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> - begin - match mode with - | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Readable -> - match Script_timestamp.to_notation t with - | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) - | Some s -> return (String (-1, s), ctxt) - end - | Address_t _, c -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in - return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) - end - | Contract_t _, (_, c) -> - Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in - return (Bytes (-1, bytes), ctxt) - | Readable -> return (String (-1, Contract.to_b58check c), ctxt) - end - | Signature_t _, s -> - Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.to_b58check s), ctxt) - end - | Mutez_t _, v -> - Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> - return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) - | Key_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key.to_b58check k), ctxt) - end - | Key_hash_t _, k -> - Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> - begin - match mode with - | Optimized -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in - return (Bytes (-1, bytes), ctxt) - | Readable -> - return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) - end - | Operation_t _, op -> - let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in - Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> - return (Bytes (-1, bytes), ctxt) - | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> - Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> - unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> - unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Pair, [ l; r ], []), ctxt) - | Union_t ((tl, _), _, _), L l -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> - return (Prim (-1, D_Left, [ l ], []), ctxt) - | Union_t (_, (tr, _), _), R r -> - Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> - unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Right, [ r ], []), ctxt) - | Option_t ((t, _), _, _), Some v -> - Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> - unparse_data ctxt mode t v >>=? fun (v, ctxt) -> - return (Prim (-1, D_Some, [ v ], []), ctxt) - | Option_t _, None -> - Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> - return (Prim (-1, D_None, [], []), ctxt) - | List_t (t, _), items -> - fold_left_s - (fun (l, ctxt) element -> - Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> - unparse_data ctxt mode t element >>=? fun (unparsed, ctxt) -> - return (unparsed :: l, ctxt)) - ([], ctxt) - items >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, List.rev items), ctxt) - | Set_t (t, _), set -> - let t = ty_of_comparable_ty t in - fold_left_s - (fun (l, ctxt) item -> - Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> - unparse_data ctxt mode t item >>=? fun (item, ctxt) -> - return (item :: l, ctxt)) - ([], ctxt) - (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Map_t (kt, vt, _), map -> - let kt = ty_of_comparable_ty kt in - fold_left_s - (fun (l, ctxt) (k, v) -> - Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> - unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt mode vt v >>=? fun (value, ctxt) -> - return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) - ([], ctxt) - (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items), ctxt) - | Big_map_t (_kt, _kv, _), _map -> - return (Micheline.Seq (-1, []), ctxt) - | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt mode (root original_code) + : type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) -> + unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t + = fun ctxt ?(mapper = fun _ -> return None) mode ty a -> + mapper (Ex_typed_value (ty, a)) >>=? function + | Some s -> return (s, ctxt) + | None -> ( + let unparse_same ctxt ty a = unparse_data ctxt ~mapper mode ty a in + Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt -> + match ty, a with + | Unit_t _, () -> + Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> + return (Prim (-1, D_Unit, [], []), ctxt) + | Int_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | Nat_t _, v -> + Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> + return (Int (-1, Script_int.to_zint v), ctxt) + | String_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt -> + return (String (-1, s), ctxt) + | Bytes_t _, s -> + Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt -> + return (Bytes (-1, s), ctxt) + | Bool_t _, true -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_True, [], []), ctxt) + | Bool_t _, false -> + Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> + return (Prim (-1, D_False, [], []), ctxt) + | Timestamp_t _, t -> + Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> + begin + match mode with + | Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Readable -> + match Script_timestamp.to_notation t with + | None -> return (Int (-1, Script_timestamp.to_zint t), ctxt) + | Some s -> return (String (-1, s), ctxt) + end + | Address_t _, c -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Contract_t _, (_, c) -> + Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in + return (Bytes (-1, bytes), ctxt) + | Readable -> return (String (-1, Contract.to_b58check c), ctxt) + end + | Signature_t _, s -> + Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.to_b58check s), ctxt) + end + | Mutez_t _, v -> + Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt -> + return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt) + | Key_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key.to_b58check k), ctxt) + end + | Key_hash_t _, k -> + Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt -> + begin + match mode with + | Optimized -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in + return (Bytes (-1, bytes), ctxt) + | Readable -> + return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) + end + | Operation_t _, op -> + let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in + Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt -> + return (Bytes (-1, bytes), ctxt) + | Pair_t ((tl, _, _), (tr, _, _), _), (l, r) -> + Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> + unparse_same ctxt tl l >>=? fun (l, ctxt) -> + unparse_same ctxt tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Pair, [ l; r ], []), ctxt) + | Union_t ((tl, _), _, _), L l -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_same ctxt tl l >>=? fun (l, ctxt) -> + return (Prim (-1, D_Left, [ l ], []), ctxt) + | Union_t (_, (tr, _), _), R r -> + Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> + unparse_same ctxt tr r >>=? fun (r, ctxt) -> + return (Prim (-1, D_Right, [ r ], []), ctxt) + | Option_t ((t, _), _, _), Some v -> + Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> + unparse_same ctxt t v >>=? fun (v, ctxt) -> + return (Prim (-1, D_Some, [ v ], []), ctxt) + | Option_t _, None -> + Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> + return (Prim (-1, D_None, [], []), ctxt) + | List_t (t, _), items -> + fold_left_s + (fun (l, ctxt) element -> + Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt -> + unparse_same ctxt t element >>=? fun (unparsed, ctxt) -> + return (unparsed :: l, ctxt)) + ([], ctxt) + items >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, List.rev items), ctxt) + | Set_t (t, _), set -> + let t = ty_of_comparable_ty t in + fold_left_s + (fun (l, ctxt) item -> + Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt -> + unparse_same ctxt t item >>=? fun (item, ctxt) -> + return (item :: l, ctxt)) + ([], ctxt) + (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Map_t (kt, vt, _), map -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + unparse_same ctxt kt k >>=? fun (key, ctxt) -> + unparse_same ctxt vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, items), ctxt) + | Big_map_t (kt, vt, _), map -> + if false then ( + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun (l, ctxt) (k, v) -> + Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> + match v with + | None -> return (l, ctxt) + | Some v -> ( + unparse_same ctxt kt k >>=? fun (key, ctxt) -> + unparse_same ctxt vt v >>=? fun (value, ctxt) -> + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) + ) + ([], ctxt) + (map_fold (fun k v acc -> (k, v) :: acc) map.diff []) >>=? fun (items, ctxt) -> + return (Micheline.Seq (-1, String (-1, "...") :: items), ctxt) + ) else ( + return (Micheline.Seq (-1, []), ctxt) + ) + | Lambda_t _, Lam (_, original_code) -> + unparse_code ctxt mode (root original_code) + ) (* Gas accounting may not be perfect in this function, as it is only called by RPCs. *) and unparse_code ctxt mode = function diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index ad85445f8..87934a3bb 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -32,12 +32,15 @@ type ex_comparable_ty = Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> e type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script +type ex_typed_value = Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value type unparsing_mode = Optimized | Readable type type_logger = int -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit +val ty_of_comparable_ty : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ty + (* ---- Sets and Maps -------------------------------------------------------*) val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set @@ -77,12 +80,19 @@ val ty_eq : 'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty -> (('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult +val stack_ty_eq : + context -> int -> + 'ta Script_typed_ir.stack_ty -> 'tb Script_typed_ir.stack_ty -> + (('ta Script_typed_ir.stack_ty, 'tb Script_typed_ir.stack_ty) eq * context) tzresult + val parse_data : ?type_logger: type_logger -> context -> 'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t + val unparse_data : - context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a -> + context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) + -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult Lwt.t val parse_ty : @@ -94,6 +104,30 @@ val parse_ty : val unparse_ty : context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t +val parse_storage_ty : + context -> + Script.node -> (ex_ty * context) tzresult + +type tc_context = + | Lambda : tc_context + | Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context + | Toplevel : { storage_type : 'sto Script_typed_ir.ty ; param_type : 'param Script_typed_ir.ty } -> tc_context + +type 'bef judgement = + | Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement + | Failed : { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement + +val parse_instr : + ?type_logger: type_logger -> + tc_context -> context -> + Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t + +val parse_returning : + ?type_logger: type_logger -> + tc_context -> context -> + 'arg Script_typed_ir.ty * Script_typed_ir.var_annot option -> 'ret Script_typed_ir.ty -> Script.node -> + (('arg, 'ret) Script_typed_ir.lambda * context) tzresult Lwt.t + val parse_toplevel : Script.expr -> (Script.node * Script.node * Script.node) tzresult