1509 lines
56 KiB
OCaml
1509 lines
56 KiB
OCaml
(*****************************************************************************)
|
|
(* *)
|
|
(* 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}
|