(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Script
open Script_typed_ir
open Script_ir_translator
(* ---- Run-time errors -----------------------------------------------------*)
type execution_trace =
(Script.location * Gas.t * (Script.expr * string option) list) list
type error +=
| Reject of Script.location * Script.expr * execution_trace option
type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *)
type error += Cannot_serialize_log
type error += Cannot_serialize_failure
type error += Cannot_serialize_storage
let () =
let open Data_encoding in
let trace_encoding =
list
@@ obj3
(req "location" Script.location_encoding)
(req "gas" Gas.encoding)
(req
"stack"
(list (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))
in
(* Reject *)
register_error_kind
`Temporary
~id:"michelson_v1.script_rejected"
~title:"Script failed"
~description:"A FAILWITH instruction was reached"
(obj3
(req "location" Script.location_encoding)
(req "with" Script.expr_encoding)
(opt "trace" trace_encoding))
(function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
(fun (loc, v, trace) -> Reject (loc, v, trace)) ;
(* Overflow *)
register_error_kind
`Temporary
~id:"michelson_v1.script_overflow"
~title:"Script failed (overflow error)"
~description:
"A FAIL instruction was reached due to the detection of an overflow"
(obj2
(req "location" Script.location_encoding)
(opt "trace" trace_encoding))
(function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)
(fun (loc, trace) -> Overflow (loc, trace)) ;
(* Runtime contract error *)
register_error_kind
`Temporary
~id:"michelson_v1.runtime_error"
~title:"Script runtime error"
~description:"Toplevel error for all runtime script errors"
(obj2
(req "contract_handle" Contract.encoding)
(req "contract_code" Script.expr_encoding))
(function
| Runtime_contract_error (contract, expr) ->
Some (contract, expr)
| _ ->
None)
(fun (contract, expr) -> Runtime_contract_error (contract, expr)) ;
(* Bad contract parameter *)
register_error_kind
`Permanent
~id:"michelson_v1.bad_contract_parameter"
~title:"Contract supplied an invalid parameter"
~description:
"Either no parameter was supplied to a contract with a non-unit \
parameter type, a non-unit parameter was passed to an account, or a \
parameter was supplied of the wrong type"
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Bad_contract_parameter c -> Some c | _ -> None)
(fun c -> Bad_contract_parameter c) ;
(* Cannot serialize log *)
register_error_kind
`Temporary
~id:"michelson_v1.cannot_serialize_log"
~title:"Not enough gas to serialize execution trace"
~description:
"Execution trace with stacks was to big to be serialized with the \
provided gas"
Data_encoding.empty
(function Cannot_serialize_log -> Some () | _ -> None)
(fun () -> Cannot_serialize_log) ;
(* Cannot serialize failure *)
register_error_kind
`Temporary
~id:"michelson_v1.cannot_serialize_failure"
~title:"Not enough gas to serialize argument of FAILWITH"
~description:
"Argument of FAILWITH was too big to be serialized with the provided gas"
Data_encoding.empty
(function Cannot_serialize_failure -> Some () | _ -> None)
(fun () -> Cannot_serialize_failure) ;
(* Cannot serialize storage *)
register_error_kind
`Temporary
~id:"michelson_v1.cannot_serialize_storage"
~title:"Not enough gas to serialize execution storage"
~description:
"The returned storage was too big to be serialized with the provided gas"
Data_encoding.empty
(function Cannot_serialize_storage -> Some () | _ -> None)
(fun () -> Cannot_serialize_storage)
(* ---- interpreter ---------------------------------------------------------*)
type 'tys stack =
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack
| Empty : end_of_stack stack
let unparse_stack ctxt (stack, stack_ty) =
(* We drop the gas limit as this function is only used for debugging/errors. *)
let ctxt = Gas.set_unlimited ctxt in
let rec unparse_stack :
type a.
a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
= function
| (Empty, Empty_t) ->
return_nil
| (Item (v, rest), Item_t (ty, rest_ty, annot)) ->
unparse_data ctxt Readable ty v
>>=? fun (data, _ctxt) ->
unparse_stack (rest, rest_ty)
>>=? fun rest ->
let annot =
match Script_ir_annot.unparse_var_annot annot with
| [] ->
None
| [a] ->
Some a
| _ ->
assert false
in
let data = Micheline.strip_locations data in
return ((data, annot) :: rest)
in
unparse_stack (stack, stack_ty)
module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter
let rec interp_stack_prefix_preserving_operation :
type fbef bef faft aft result.
(fbef stack -> (faft stack * result) tzresult Lwt.t) ->
(fbef, faft, bef, aft) stack_prefix_preservation_witness ->
bef stack ->
(aft stack * result) tzresult Lwt.t =
fun f n stk ->
match (n, stk) with
| ( Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
Item
( v0,
Item
( v1,
Item
( v2,
Item
( v3,
Item
( v4,
Item
( v5,
Item
( v6,
Item
( v7,
Item
( v8,
Item
( v9,
Item
( va,
Item
( vb,
Item
( vc,
Item
( vd,
Item
( ve,
Item
(vf, rest)
) ) ) ) ) ) )
) ) ) ) ) ) ) ) ) ->
interp_stack_prefix_preserving_operation f n rest
>>=? fun (rest', result) ->
return
( Item
( v0,
Item
( v1,
Item
( v2,
Item
( v3,
Item
( v4,
Item
( v5,
Item
( v6,
Item
( v7,
Item
( v8,
Item
( v9,
Item
( va,
Item
( vb,
Item
( vc,
Item
( vd,
Item
( ve,
Item
( vf,
rest'
) ) )
) ) ) ) ) ) ) ) )
) ) ) ),
result )
| ( Prefix (Prefix (Prefix (Prefix n))),
Item (v0, Item (v1, Item (v2, Item (v3, rest)))) ) ->
interp_stack_prefix_preserving_operation f n rest
>>=? fun (rest', result) ->
return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result)
| (Prefix n, Item (v, rest)) ->
interp_stack_prefix_preserving_operation f n rest
>>=? fun (rest', result) -> return (Item (v, rest'), result)
| (Rest, v) ->
f v
type step_constants = {
source : Contract.t;
payer : Contract.t;
self : Contract.t;
amount : Tez.t;
chain_id : Chain_id.t;
}
let rec step :
type b a.
?log:execution_trace ref ->
context ->
step_constants ->
(b, a) descr ->
b stack ->
(a stack * context) tzresult Lwt.t =
fun ?log ctxt step_constants ({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 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 ?log ctxt step_constants bt rest
| (If_none (_, bf), Item (Some v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants 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 ?log ctxt step_constants bt (Item (v, rest))
| (If_left (_, bf), Item (R v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants 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 ?log ctxt step_constants bf rest
| (If_cons (bt, _), Item (hd :: tl, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt ->
step ?log ctxt step_constants 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_map)
>>=? fun ctxt ->
match l with
| [] ->
return (Item (List.rev acc, rest), ctxt)
| hd :: tl ->
step ?log ctxt step_constants 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.loop_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_iter)
>>=? fun ctxt ->
match l with
| [] ->
return (stack, ctxt)
| hd :: tl ->
step ?log ctxt step_constants 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_iter)
>>=? fun ctxt ->
match l with
| [] ->
return (stack, ctxt)
| hd :: tl ->
step ?log ctxt step_constants 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_map)
>>=? fun ctxt ->
match l with
| [] ->
return (Item (acc, rest), ctxt)
| ((k, _) as hd) :: tl ->
step ?log ctxt step_constants 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 (res, 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_iter)
>>=? fun ctxt ->
match l with
| [] ->
return (stack, ctxt)
| hd :: tl ->
step ?log ctxt step_constants 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 *)
| (Empty_big_map (tk, tv), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
>>=? fun ctxt ->
logged_return
(Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt)
| (Big_map_mem, Item (key, Item (map, rest))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff))
>>=? fun ctxt ->
Script_ir_translator.big_map_mem ctxt 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.map_get key map.diff))
>>=? fun ctxt ->
Script_ir_translator.big_map_get ctxt 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)
(fun k v m -> Interp_costs.map_update k (Some v) m.diff)
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 ->
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) )
| (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 ->
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) )
(* 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) -> (
match (Tez.of_mutez q, Tez.of_mutez r) with
| (Some q, Some r) ->
Some (q, r)
(* Cannot overflow *)
| _ ->
assert false )
(* 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 ->
match Script_int.shift_left_n x y with
| None ->
fail (Overflow (loc, get_log log))
| Some x ->
logged_return (Item (x, rest), ctxt) )
| (Lsr_nat, Item (x, Item (y, rest))) -> (
Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y))
>>=? fun ctxt ->
match Script_int.shift_right_n x y with
| None ->
fail (Overflow (loc, get_log log))
| Some r ->
logged_return (Item (r, rest), ctxt) )
| (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 ?log ctxt step_constants hd stack
>>=? fun (trans, ctxt) -> step ?log ctxt step_constants tl trans
| (If (bt, _), Item (true, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bt rest
| (If (_, bf), Item (false, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bf rest
| (Loop body, Item (true, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
>>=? fun ctxt ->
step ?log ctxt step_constants body rest
>>=? fun (trans, ctxt) -> step ?log ctxt step_constants 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 ?log ctxt step_constants body (Item (v, rest))
>>=? fun (trans, ctxt) -> step ?log ctxt step_constants 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 ?log ctxt step_constants 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 step_constants lam arg
>>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
| (Apply capture_ty, Item (capture, Item (lam, rest))) -> (
Lwt.return (Gas.consume ctxt Interp_costs.apply)
>>=? fun ctxt ->
let (Lam (descr, expr)) = lam in
let (Item_t (full_arg_ty, _, _)) = descr.bef in
unparse_data ctxt Optimized capture_ty capture
>>=? fun (const_expr, ctxt) ->
unparse_ty ctxt capture_ty
>>=? fun (ty_expr, ctxt) ->
match full_arg_ty with
| Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) ->
let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in
let const_descr =
( {
loc = descr.loc;
bef = arg_stack_ty;
aft = Item_t (capture_ty, arg_stack_ty, None);
instr = Const capture;
}
: (_, _) descr )
in
let pair_descr =
( {
loc = descr.loc;
bef = Item_t (capture_ty, arg_stack_ty, None);
aft = Item_t (full_arg_ty, Empty_t, None);
instr = Cons_pair;
}
: (_, _) descr )
in
let seq_descr =
( {
loc = descr.loc;
bef = arg_stack_ty;
aft = Item_t (full_arg_ty, Empty_t, None);
instr = Seq (const_descr, pair_descr);
}
: (_, _) descr )
in
let full_descr =
( {
loc = descr.loc;
bef = arg_stack_ty;
aft = descr.aft;
instr = Seq (seq_descr, descr);
}
: (_, _) descr )
in
let full_expr =
Micheline.Seq
( 0,
[ Prim (0, I_PUSH, [ty_expr; const_expr], []);
Prim (0, I_PAIR, [], []);
expr ] )
in
let lam' = Lam (full_descr, full_expr) in
logged_return (Item (lam', rest), ctxt)
| _ ->
assert false )
| (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 ty, Item (a, Item (b, rest))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b))
>>=? fun ctxt ->
logged_return
( Item
( Script_int.of_int
@@ Script_ir_translator.compare_comparable ty a b,
rest ),
ctxt )
(* 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 ~legacy:false 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 ((_, address), rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.address)
>>=? fun ctxt -> logged_return (Item (address, rest), ctxt)
| (Contract (t, entrypoint), Item (contract, rest)) -> (
Lwt.return (Gas.consume ctxt Interp_costs.contract)
>>=? fun ctxt ->
match (contract, entrypoint) with
| ((contract, "default"), entrypoint)
| ((contract, entrypoint), "default") ->
Script_ir_translator.parse_contract_for_script
~legacy:false
ctxt
loc
t
contract
~entrypoint
>>=? fun (ctxt, maybe_contract) ->
logged_return (Item (maybe_contract, rest), ctxt)
| _ ->
logged_return (Item (None, rest), ctxt) )
| ( Transfer_tokens,
Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) )
->
Lwt.return (Gas.consume ctxt Interp_costs.transfer)
>>=? fun ctxt ->
collect_big_maps ctxt tp p
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
ctxt
Optimized
tp
p
~to_duplicate
~to_update
~temporary:true
>>=? fun (p, big_map_diff, ctxt) ->
unparse_data ctxt Optimized tp p
>>=? fun (p, ctxt) ->
let operation =
Transaction
{
amount;
destination;
entrypoint;
parameters = Script.lazy_expr (Micheline.strip_locations p);
}
in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
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) ->
(* store in optimized binary representation - as unparsed with [Optimized]. *)
let manager_bytes =
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding
manager
in
let storage =
Script_repr.lazy_expr @@ Micheline.strip_locations
@@ Micheline.Bytes (0, manager_bytes)
in
let script = {code = Legacy_support.manager_script_code; storage} in
let operation =
Origination {credit; delegate; preorigination = Some contract; script}
in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
None ),
Item ((contract, "default"), 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, "default")), rest), ctxt)
| ( Create_contract (storage_type, param_type, Lam (_, code), root_name),
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) ->
let unparsed_param_type =
Script_ir_translator.add_field_annot
(Option.map ~f:(fun n -> `Field_annot n) root_name)
None
unparsed_param_type
in
unparse_ty ctxt storage_type
>>=? fun (unparsed_storage_type, ctxt) ->
let code =
Script.lazy_expr
@@ Micheline.strip_locations
(Seq
( 0,
[ Prim (0, K_parameter, [unparsed_param_type], []);
Prim (0, K_storage, [unparsed_storage_type], []);
Prim (0, K_code, [code], []) ] ))
in
collect_big_maps ctxt storage_type init
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
ctxt
Optimized
storage_type
init
~to_duplicate
~to_update
~temporary:true
>>=? fun (init, big_map_diff, ctxt) ->
unparse_data ctxt Optimized storage_type init
>>=? fun (storage, ctxt) ->
let storage = Script.lazy_expr @@ Micheline.strip_locations storage in
( if spendable then
Legacy_support.add_do
~manager_pkh:manager
~script_code:code
~script_storage:storage
else if delegatable then
Legacy_support.add_set_delegate
~manager_pkh:manager
~script_code:code
~script_storage:storage
else if Legacy_support.has_default_entrypoint code then
Legacy_support.add_root_entrypoint code
>>=? fun code -> return (code, storage)
else return (code, storage) )
>>=? fun (code, storage) ->
Contract.fresh_contract_from_current_nonce ctxt
>>=? fun (ctxt, contract) ->
let operation =
Origination
{
credit;
delegate;
preorigination = Some contract;
script = {code; storage};
}
in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
Item ((contract, "default"), rest) ),
ctxt )
| ( Create_contract_2 (storage_type, param_type, Lam (_, code), root_name),
(* Removed the instruction's arguments manager, spendable and delegatable *)
Item (delegate, 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) ->
let unparsed_param_type =
Script_ir_translator.add_field_annot
(Option.map ~f:(fun n -> `Field_annot n) root_name)
None
unparsed_param_type
in
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, [code], []) ] ))
in
collect_big_maps ctxt storage_type init
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
ctxt
Optimized
storage_type
init
~to_duplicate
~to_update
~temporary:true
>>=? fun (init, big_map_diff, ctxt) ->
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;
delegate;
preorigination = Some contract;
script =
{
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 = step_constants.self; operation; nonce},
big_map_diff ),
Item ((contract, "default"), 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 = step_constants.self; operation; nonce},
None ),
rest ),
ctxt )
| (Balance, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.balance)
>>=? fun ctxt ->
Contract.get_balance ctxt step_constants.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 key message))
>>=? 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_blake2b bytes))
>>=? 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_sha256 bytes))
>>=? 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_sha512 bytes))
>>=? 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 ((step_constants.payer, "default"), rest), ctxt)
| (Sender, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.source)
>>=? fun ctxt ->
logged_return (Item ((step_constants.source, "default"), rest), ctxt)
| (Self (t, entrypoint), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.self)
>>=? fun ctxt ->
logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt)
| (Amount, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.amount)
>>=? fun ctxt -> logged_return (Item (step_constants.amount, rest), ctxt)
| (Dig (n, n'), stack) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun (Item (v, rest)) -> return (rest, v))
n'
stack
>>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt)
| (Dug (n, n'), Item (v, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun stk -> return (Item (v, stk), ()))
n'
rest
>>=? fun (aft, ()) -> logged_return (aft, ctxt)
| (Dipn (n, n', b), stack) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun stk ->
step ?log ctxt step_constants b stk
>>=? fun (res, ctxt') -> return (res, ctxt'))
n'
stack
>>=? fun (aft, ctxt') -> logged_return (aft, ctxt')
| (Dropn (n, n'), stack) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun stk -> return (stk, stk))
n'
stack
>>=? fun (_, rest) -> logged_return (rest, ctxt)
| (ChainId, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.chain_id)
>>=? fun ctxt ->
logged_return (Item (step_constants.chain_id, rest), ctxt)
and interp :
type p r.
?log:execution_trace ref ->
context ->
step_constants ->
(p, r) lambda ->
p ->
(r * context) tzresult Lwt.t =
fun ?log ctxt step_constants (Lam (code, _)) arg ->
let stack = Item (arg, Empty) in
( match log with
| None ->
return_unit
| Some log ->
trace Cannot_serialize_log (unparse_stack ctxt (stack, code.bef))
>>=? fun stack ->
log := (code.loc, Gas.level ctxt, stack) :: !log ;
return_unit )
>>=? fun () ->
step ?log ctxt step_constants code stack
>>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt)
(* ---- contract handling ---------------------------------------------------*)
and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg :
( Script.expr
* packed_internal_operation list
* context
* Contract.big_map_diff option )
tzresult
Lwt.t =
parse_script ctxt unparsed_script ~legacy:true
>>=? fun (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) ->
trace
(Bad_contract_parameter step_constants.self)
(Lwt.return (find_entrypoint arg_type ~root_name entrypoint))
>>=? fun (box, _) ->
trace
(Bad_contract_parameter step_constants.self)
(parse_data ctxt ~legacy:false arg_type (box arg))
>>=? fun (arg, ctxt) ->
Script.force_decode ctxt unparsed_script.code
>>=? fun (script_code, ctxt) ->
Script_ir_translator.collect_big_maps ctxt arg_type arg
>>=? fun (to_duplicate, ctxt) ->
Script_ir_translator.collect_big_maps ctxt storage_type storage
>>=? fun (to_update, ctxt) ->
trace
(Runtime_contract_error (step_constants.self, script_code))
(interp ?log ctxt step_constants code (arg, storage))
>>=? fun ((ops, storage), ctxt) ->
Script_ir_translator.extract_big_map_diff
ctxt
mode
~temporary:false
~to_duplicate
~to_update
storage_type
storage
>>=? fun (storage, big_map_diff, ctxt) ->
trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)
>>=? fun (storage, ctxt) ->
let (ops, op_diffs) = List.split ops in
let big_map_diff =
match
List.flatten
(List.map (Option.unopt ~default:[]) (op_diffs @ [big_map_diff]))
with
| [] ->
None
| diff ->
Some diff
in
return (Micheline.strip_locations storage, ops, ctxt, big_map_diff)
type execution_result = {
ctxt : context;
storage : Script.expr;
big_map_diff : Contract.big_map_diff option;
operations : packed_internal_operation list;
}
let trace ctxt mode step_constants ~script ~entrypoint ~parameter =
let log = ref [] in
execute
~log
ctxt
mode
step_constants
~entrypoint
script
(Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) ->
let trace = List.rev !log in
return ({ctxt; storage; big_map_diff; operations}, trace)
let execute ctxt mode step_constants ~script ~entrypoint ~parameter =
execute
ctxt
mode
step_constants
~entrypoint
script
(Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) ->
return {ctxt; storage; big_map_diff; operations}