script_interpreter_defs.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2021-2022 Nomadic Labs <contact@nomadic-labs.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. *)
(* *)
(*****************************************************************************)
(*
This module provides auxiliary definitions used in the interpreter.
These are internal private definitions. Do not rely on them outside
the interpreter.
*)
open Alpha_context
open Script
open Script_typed_ir
open Script_ir_translator
open Local_gas_counter
type error += Rollup_invalid_transaction_amount
let () =
register_error_kind
`Permanent
~id:"operation.rollup_invalid_transaction_amount"
~title:"Transaction amount to a rollup must be zero"
~description:
"Because rollups are outside of the delegation mechanism of Tezos, they \
cannot own Tez, and therefore transactions targeting a rollup must have \
its amount field set to zero."
~pp:(fun ppf () ->
Format.pp_print_string ppf "Transaction amount to a rollup must be zero.")
Data_encoding.unit
(function Rollup_invalid_transaction_amount -> Some () | _ -> None)
(fun () -> Rollup_invalid_transaction_amount)
(*
Computing the cost of Michelson instructions
============================================
The function [cost_of_instr] provides a cost model for Michelson
instructions. It is used by the interpreter to track the
consumption of gas. This consumption may depend on the values
on the stack.
*)
module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter
let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost =
fun i accu stack ->
match i with
| IList_map _ ->
let list = accu in
Interp_costs.list_map list
| IList_iter _ ->
let list = accu in
Interp_costs.list_iter list
| ISet_iter _ ->
let set = accu in
Interp_costs.set_iter set
| ISet_mem _ ->
let v = accu and set, _ = stack in
Interp_costs.set_mem v set
| ISet_update _ ->
let v = accu and _, (set, _) = stack in
Interp_costs.set_update v set
| IMap_map _ ->
let map = accu in
Interp_costs.map_map map
| IMap_iter _ ->
let map = accu in
Interp_costs.map_iter map
| IMap_mem _ ->
let v = accu and map, _ = stack in
Interp_costs.map_mem v map
| IMap_get _ ->
let v = accu and map, _ = stack in
Interp_costs.map_get v map
| IMap_update _ ->
let k = accu and _, (map, _) = stack in
Interp_costs.map_update k map
| IMap_get_and_update _ ->
let k = accu and _, (map, _) = stack in
Interp_costs.map_get_and_update k map
| IBig_map_mem _ ->
let Big_map map, _ = stack in
Interp_costs.big_map_mem map.diff
| IBig_map_get _ ->
let Big_map map, _ = stack in
Interp_costs.big_map_get map.diff
| IBig_map_update _ ->
let _, (Big_map map, _) = stack in
Interp_costs.big_map_update map.diff
| IBig_map_get_and_update _ ->
let _, (Big_map map, _) = stack in
Interp_costs.big_map_get_and_update map.diff
| IAdd_seconds_to_timestamp _ ->
let n = accu and t, _ = stack in
Interp_costs.add_seconds_timestamp n t
| IAdd_timestamp_to_seconds _ ->
let t = accu and n, _ = stack in
Interp_costs.add_timestamp_seconds t n
| ISub_timestamp_seconds _ ->
let t = accu and n, _ = stack in
Interp_costs.sub_timestamp_seconds t n
| IDiff_timestamps _ ->
let t1 = accu and t2, _ = stack in
Interp_costs.diff_timestamps t1 t2
| IConcat_string_pair _ ->
let x = accu and y, _ = stack in
Interp_costs.concat_string_pair x y
| IConcat_string _ ->
let ss = accu in
Interp_costs.concat_string_precheck ss
| ISlice_string _ ->
let (_offset : Script_int.n Script_int.num) = accu in
let _length, (s, _) = stack in
Interp_costs.slice_string s
| IConcat_bytes_pair _ ->
let x = accu and y, _ = stack in
Interp_costs.concat_bytes_pair x y
| IConcat_bytes _ ->
let ss = accu in
Interp_costs.concat_string_precheck ss
| ISlice_bytes _ ->
let _, (s, _) = stack in
Interp_costs.slice_bytes s
| IMul_teznat _ -> Interp_costs.mul_teznat
| IMul_nattez _ -> Interp_costs.mul_nattez
| IAbs_int _ ->
let x = accu in
Interp_costs.abs_int x
| INeg _ ->
let x = accu in
Interp_costs.neg x
| IAdd_int _ ->
let x = accu and y, _ = stack in
Interp_costs.add_int x y
| IAdd_nat _ ->
let x = accu and y, _ = stack in
Interp_costs.add_nat x y
| ISub_int _ ->
let x = accu and y, _ = stack in
Interp_costs.sub_int x y
| IMul_int _ ->
let x = accu and y, _ = stack in
Interp_costs.mul_int x y
| IMul_nat _ ->
let x = accu and y, _ = stack in
Interp_costs.mul_nat x y
| IEdiv_teznat _ ->
let x = accu and y, _ = stack in
Interp_costs.ediv_teznat x y
| IEdiv_int _ ->
let x = accu and y, _ = stack in
Interp_costs.ediv_int x y
| IEdiv_nat _ ->
let x = accu and y, _ = stack in
Interp_costs.ediv_nat x y
| ILsl_nat _ ->
let x = accu in
Interp_costs.lsl_nat x
| ILsr_nat _ ->
let x = accu in
Interp_costs.lsr_nat x
| IOr_nat _ ->
let x = accu and y, _ = stack in
Interp_costs.or_nat x y
| IAnd_nat _ ->
let x = accu and y, _ = stack in
Interp_costs.and_nat x y
| IAnd_int_nat _ ->
let x = accu and y, _ = stack in
Interp_costs.and_int_nat x y
| IXor_nat _ ->
let x = accu and y, _ = stack in
Interp_costs.xor_nat x y
| INot_int _ ->
let x = accu in
Interp_costs.not_int x
| ICompare (_, ty, _) ->
let a = accu and b, _ = stack in
Interp_costs.compare ty a b
| ICheck_signature _ ->
let key = accu and _, (message, _) = stack in
Interp_costs.check_signature key message
| IHash_key _ ->
let pk = accu in
Interp_costs.hash_key pk
| IBlake2b _ ->
let bytes = accu in
Interp_costs.blake2b bytes
| ISha256 _ ->
let bytes = accu in
Interp_costs.sha256 bytes
| ISha512 _ ->
let bytes = accu in
Interp_costs.sha512 bytes
| IKeccak _ ->
let bytes = accu in
Interp_costs.keccak bytes
| ISha3 _ ->
let bytes = accu in
Interp_costs.sha3 bytes
| IPairing_check_bls12_381 _ ->
let pairs = accu in
Interp_costs.pairing_check_bls12_381 pairs
| ISapling_verify_update _ ->
let tx = accu in
let inputs = Gas_input_size.sapling_transaction_inputs tx in
let outputs = Gas_input_size.sapling_transaction_outputs tx in
let bound_data = Gas_input_size.sapling_transaction_bound_data tx in
Interp_costs.sapling_verify_update ~inputs ~outputs ~bound_data
| ISapling_verify_update_deprecated _ ->
let tx = accu in
let inputs = List.length tx.inputs in
let outputs = List.length tx.outputs in
Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs
| ISplit_ticket _ ->
let (amount_a, amount_b), _ = stack in
Interp_costs.split_ticket amount_a amount_b
| IJoin_tickets (_, ty, _) ->
let ticket_a, ticket_b = accu in
Interp_costs.join_tickets ty ticket_a ticket_b
| IHalt _ -> Interp_costs.halt
| IDrop _ -> Interp_costs.drop
| IDup _ -> Interp_costs.dup
| ISwap _ -> Interp_costs.swap
| IConst _ -> Interp_costs.const
| ICons_some _ -> Interp_costs.cons_some
| ICons_none _ -> Interp_costs.cons_none
| IIf_none _ -> Interp_costs.if_none
| IOpt_map _ -> Interp_costs.opt_map
| ICons_pair _ -> Interp_costs.cons_pair
| IUnpair _ -> Interp_costs.unpair
| ICar _ -> Interp_costs.car
| ICdr _ -> Interp_costs.cdr
| ICons_left _ -> Interp_costs.cons_left
| ICons_right _ -> Interp_costs.cons_right
| IIf_left _ -> Interp_costs.if_left
| ICons_list _ -> Interp_costs.cons_list
| INil _ -> Interp_costs.nil
| IIf_cons _ -> Interp_costs.if_cons
| IList_size _ -> Interp_costs.list_size
| IEmpty_set _ -> Interp_costs.empty_set
| ISet_size _ -> Interp_costs.set_size
| IEmpty_map _ -> Interp_costs.empty_map
| IMap_size _ -> Interp_costs.map_size
| IEmpty_big_map _ -> Interp_costs.empty_big_map
| IString_size _ -> Interp_costs.string_size
| IBytes_size _ -> Interp_costs.bytes_size
| IAdd_tez _ -> Interp_costs.add_tez
| ISub_tez _ -> Interp_costs.sub_tez
| ISub_tez_legacy _ -> Interp_costs.sub_tez_legacy
| IOr _ -> Interp_costs.bool_or
| IAnd _ -> Interp_costs.bool_and
| IXor _ -> Interp_costs.bool_xor
| INot _ -> Interp_costs.bool_not
| IIs_nat _ -> Interp_costs.is_nat
| IInt_nat _ -> Interp_costs.int_nat
| IInt_bls12_381_fr _ -> Interp_costs.int_bls12_381_fr
| IEdiv_tez _ -> Interp_costs.ediv_tez
| IIf _ -> Interp_costs.if_
| ILoop _ -> Interp_costs.loop
| ILoop_left _ -> Interp_costs.loop_left
| IDip _ -> Interp_costs.dip
| IExec _ -> Interp_costs.exec
| IApply _ -> (
let l, _ = stack in
match l with
| Lam _ -> Interp_costs.apply ~rec_flag:false
| LamRec _ -> Interp_costs.apply ~rec_flag:true)
| ILambda _ -> Interp_costs.lambda
| IFailwith _ -> Gas.free
| IEq _ -> Interp_costs.eq
| INeq _ -> Interp_costs.neq
| ILt _ -> Interp_costs.lt
| ILe _ -> Interp_costs.le
| IGt _ -> Interp_costs.gt
| IGe _ -> Interp_costs.ge
| IPack _ -> Gas.free
| IUnpack _ ->
let b = accu in
Interp_costs.unpack b
| IAddress _ -> Interp_costs.address
| IContract _ -> Interp_costs.contract
| ITransfer_tokens _ -> Interp_costs.transfer_tokens
| IView _ -> Interp_costs.view
| IImplicit_account _ -> Interp_costs.implicit_account
| ISet_delegate _ -> Interp_costs.set_delegate
| IBalance _ -> Interp_costs.balance
| ILevel _ -> Interp_costs.level
| INow _ -> Interp_costs.now
| IMin_block_time _ -> Interp_costs.min_block_time
| ISapling_empty_state _ -> Interp_costs.sapling_empty_state
| ISource _ -> Interp_costs.source
| ISender _ -> Interp_costs.sender
| ISelf _ -> Interp_costs.self
| ISelf_address _ -> Interp_costs.self_address
| IAmount _ -> Interp_costs.amount
| IDig (_, n, _, _) -> Interp_costs.dign n
| IDug (_, n, _, _) -> Interp_costs.dugn n
| IDipn (_, n, _, _, _) -> Interp_costs.dipn n
| IDropn (_, n, _, _) -> Interp_costs.dropn n
| IChainId _ -> Interp_costs.chain_id
| ICreate_contract _ -> Interp_costs.create_contract
| INever _ -> ( match accu with _ -> .)
| IVoting_power _ -> Interp_costs.voting_power
| ITotal_voting_power _ -> Interp_costs.total_voting_power
| IAdd_bls12_381_g1 _ -> Interp_costs.add_bls12_381_g1
| IAdd_bls12_381_g2 _ -> Interp_costs.add_bls12_381_g2
| IAdd_bls12_381_fr _ -> Interp_costs.add_bls12_381_fr
| IMul_bls12_381_g1 _ -> Interp_costs.mul_bls12_381_g1
| IMul_bls12_381_g2 _ -> Interp_costs.mul_bls12_381_g2
| IMul_bls12_381_fr _ -> Interp_costs.mul_bls12_381_fr
| INeg_bls12_381_g1 _ -> Interp_costs.neg_bls12_381_g1
| INeg_bls12_381_g2 _ -> Interp_costs.neg_bls12_381_g2
| INeg_bls12_381_fr _ -> Interp_costs.neg_bls12_381_fr
| IMul_bls12_381_fr_z _ ->
let z = accu in
Interp_costs.mul_bls12_381_fr_z z
| IMul_bls12_381_z_fr _ ->
let z, _ = stack in
Interp_costs.mul_bls12_381_z_fr z
| IDup_n (_, n, _, _) -> Interp_costs.dupn n
| IComb (_, n, _, _) -> Interp_costs.comb n
| IUncomb (_, n, _, _) -> Interp_costs.uncomb n
| IComb_get (_, n, _, _) -> Interp_costs.comb_get n
| IComb_set (_, n, _, _) -> Interp_costs.comb_set n
| ITicket _ | ITicket_deprecated _ -> Interp_costs.ticket
| IRead_ticket _ -> Interp_costs.read_ticket
| IOpen_chest _ ->
let (_chest_key : Script_timelock.chest_key) = accu
and chest, (time, _) = stack in
Interp_costs.open_chest ~chest ~time:(Script_int.to_zint time)
| IEmit _ -> Interp_costs.emit
| ILog _ -> Gas.free
[@@ocaml.inline always]
let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost =
fun ks ->
match ks with
| KLog _ -> Gas.free
| KNil -> Interp_costs.Control.nil
| KCons (_, _) -> Interp_costs.Control.cons
| KReturn _ -> Interp_costs.Control.return
| KMap_head (_, _) -> Interp_costs.Control.map_head
| KUndip (_, _, _) -> Interp_costs.Control.undip
| KLoop_in (_, _) -> Interp_costs.Control.loop_in
| KLoop_in_left (_, _) -> Interp_costs.Control.loop_in_left
| KIter (_, _, _, _) -> Interp_costs.Control.iter
| KList_enter_body (_, xs, _, _, len, _) ->
Interp_costs.Control.list_enter_body xs len
| KList_exit_body (_, _, _, _, _, _) -> Interp_costs.Control.list_exit_body
| KMap_enter_body (_, _, _, _, _) -> Interp_costs.Control.map_enter_body
| KMap_exit_body (_, _, map, key, _, _) ->
Interp_costs.Control.map_exit_body key map
| KView_exit (_, _) -> Interp_costs.Control.view_exit
(*
[step] calls [consume_instr] at the beginning of each execution step.
[Local_gas_counter.consume] is used in the implementation of
[IConcat_string] and [IConcat_bytes] because in that special cases, the
cost is expressed with respect to a non-constant-time computation on the
inputs.
*)
let consume_instr local_gas_counter k accu stack =
let cost = cost_of_instr k accu stack in
consume_opt local_gas_counter cost
[@@ocaml.inline always]
let consume_control local_gas_counter ks =
let cost = cost_of_control ks in
consume_opt local_gas_counter cost
[@@ocaml.inline always]
let get_log = function
| None -> Lwt.return (Ok None)
| Some logger -> logger.get_log ()
[@@ocaml.inline always]
(*
Auxiliary functions used by the interpretation loop
===================================================
*)
(* The following function pops n elements from the stack
and push their reintroduction in the continuations stack. *)
let rec kundip :
type a s e z c u d w b t.
(a, s, e, z, c, u, d, w) stack_prefix_preservation_witness ->
c ->
u ->
(d, w, b, t) kinstr ->
a * s * (e, z, b, t) kinstr =
fun w accu stack k ->
match w with
| KPrefix (loc, ty, w) ->
let k = IConst (loc, ty, accu, k) in
let accu, stack = stack in
kundip w accu stack k
| KRest -> (accu, stack, k)
(* [apply ctxt gas ty v lam] specializes [lam] by fixing its first
formal argument to [v]. The type of [v] is represented by [ty]. *)
let apply ctxt gas capture_ty capture lam =
let loc = Micheline.dummy_location in
let ctxt = update_context gas ctxt in
Script_ir_unparser.unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) ->
unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) ->
let make_expr expr =
Micheline.(
Seq
( loc,
Prim (loc, I_PUSH, [ty_expr; Micheline.root const_expr], [])
:: Prim (loc, I_PAIR, [], [])
:: expr ))
in
let lam' =
match lam with
| LamRec (descr, expr) -> (
let (Item_t (full_arg_ty, Item_t (Lambda_t (_, _, _), Bot_t))) =
descr.kbef
in
let (Item_t (ret_ty, Bot_t)) = descr.kaft in
Script_ir_unparser.unparse_ty ~loc ctxt full_arg_ty
>>?= fun (arg_ty_expr, ctxt) ->
Script_ir_unparser.unparse_ty ~loc ctxt ret_ty
>>?= fun (ret_ty_expr, ctxt) ->
match full_arg_ty with
| Pair_t (capture_ty, arg_ty, _, _) ->
let arg_stack_ty = Item_t (arg_ty, Bot_t) in
(* To avoid duplicating the recursive lambda [lam], we
return a regular lambda that builds the tuple of
parameters and applies it to `lam`. Since `lam` is
recursive it will push itself on top of the stack at
execution time. *)
let full_descr =
{
kloc = descr.kloc;
kbef = arg_stack_ty;
kaft = descr.kaft;
kinstr =
IConst
( descr.kloc,
capture_ty,
capture,
ICons_pair
( descr.kloc,
ILambda
( descr.kloc,
lam,
ISwap
( descr.kloc,
IExec
( descr.kloc,
Some descr.kaft,
IHalt descr.kloc ) ) ) ) );
}
in
let full_expr =
make_expr
Micheline.
[
Prim
(loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; expr], []);
Prim (loc, I_SWAP, [], []);
Prim (loc, I_EXEC, [], []);
]
in
return (Lam (full_descr, full_expr), ctxt))
| Lam (descr, expr) -> (
let (Item_t (full_arg_ty, Bot_t)) = descr.kbef in
match full_arg_ty with
| Pair_t (capture_ty, arg_ty, _, _) ->
let arg_stack_ty = Item_t (arg_ty, Bot_t) in
let full_descr =
{
kloc = descr.kloc;
kbef = arg_stack_ty;
kaft = descr.kaft;
kinstr =
IConst
( descr.kloc,
capture_ty,
capture,
ICons_pair (descr.kloc, descr.kinstr) );
}
in
let full_expr = make_expr [expr] in
return (Lam (full_descr, full_expr), ctxt))
in
lam' >>=? fun (lam', ctxt) ->
let gas, ctxt = local_gas_counter_and_outdated_context ctxt in
return (lam', ctxt, gas)
let make_transaction_to_tx_rollup (type t) ctxt ~destination ~amount
~(parameters_ty : ((t ticket, tx_rollup_l2_address) pair, _) ty) ~parameters
=
(* The entrypoints of a transaction rollup are polymorphic wrt. the
tickets it can process. However, two Michelson values can have
the same Micheline representation, but different types. What
this means is that when we start the execution of a transaction
rollup, the type of its argument is lost if we just give it the
values provided by the Michelson script.
To address this issue, we instrument a transfer to a transaction
rollup to inject the exact type of the entrypoint as used by
the smart contract. This allows the transaction rollup to extract
the type of the ticket. *)
error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount
>>?= fun () ->
let (Pair_t (Ticket_t (tp, _), _, _, _)) = parameters_ty in
unparse_data ctxt Optimized parameters_ty parameters
>>=? fun (unparsed_parameters, ctxt) ->
Lwt.return
( Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt tp
>>? fun (ty, ctxt) ->
let unparsed_parameters =
Micheline.Seq
(Micheline.dummy_location, [Micheline.root unparsed_parameters; ty])
in
Gas.consume ctxt (Script.strip_locations_cost unparsed_parameters)
>|? fun ctxt ->
let unparsed_parameters = Micheline.strip_locations unparsed_parameters in
( Transaction_to_tx_rollup
{destination; parameters_ty; parameters; unparsed_parameters},
ctxt ) )
let make_transaction_to_sc_rollup ctxt ~destination ~amount ~entrypoint
~parameters_ty ~parameters =
error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount
>>?= fun () ->
unparse_data ctxt Optimized parameters_ty parameters
>|=? fun (unparsed_parameters, ctxt) ->
( Transaction_to_sc_rollup
{destination; entrypoint; parameters_ty; parameters; unparsed_parameters},
ctxt )
(** [emit_event] generates an internal operation that will effect an event emission
if the contract code returns this successfully. *)
let emit_event (type t tc) (ctxt, sc) gas ~(event_type : (t, tc) ty)
~unparsed_ty ~tag ~(event_data : t) =
let ctxt = update_context gas ctxt in
(* No need to take care of lazy storage as only packable types are allowed *)
let lazy_storage_diff = None in
unparse_data ctxt Optimized event_type event_data
>>=? fun (unparsed_data, ctxt) ->
fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->
let operation = Event {ty = unparsed_ty; tag; unparsed_data} in
let iop = {source = Contract.Originated sc.self; operation; nonce} in
let res = {piop = Internal_operation iop; lazy_storage_diff} in
let gas, ctxt = local_gas_counter_and_outdated_context ctxt in
return (res, ctxt, gas)
let make_transaction_to_zk_rollup (type t) ctxt ~destination ~amount
~(parameters_ty : ((t ticket, bytes) pair, _) ty) ~parameters =
error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount
>>?= fun () ->
unparse_data ctxt Optimized parameters_ty parameters
>|=? fun (unparsed_parameters, ctxt) ->
( Transaction_to_zk_rollup
{destination; parameters_ty; parameters; unparsed_parameters},
ctxt )
(* [transfer (ctxt, sc) gas tez parameters_ty parameters destination entrypoint]
creates an operation that transfers an amount of [tez] to a destination and
an entrypoint instantiated with argument [parameters] of type
[parameters_ty]. *)
let transfer (type t) (ctxt, sc) gas amount location
(typed_contract : t typed_contract) (parameters : t) =
let ctxt = update_context gas ctxt in
(match typed_contract with
| Typed_implicit destination ->
let () = parameters in
return (Transaction_to_implicit {destination; amount}, None, ctxt)
| Typed_originated
{arg_ty = parameters_ty; contract_hash = destination; entrypoint} ->
collect_lazy_storage ctxt parameters_ty parameters
>>?= fun (to_duplicate, ctxt) ->
let to_update = no_lazy_storage_id in
extract_lazy_storage_diff
ctxt
Optimized
parameters_ty
parameters
~to_duplicate
~to_update
~temporary:true
>>=? fun (parameters, lazy_storage_diff, ctxt) ->
unparse_data ctxt Optimized parameters_ty parameters
>|=? fun (unparsed_parameters, ctxt) ->
( Transaction_to_smart_contract
{
destination;
amount;
entrypoint;
location;
parameters_ty;
parameters;
unparsed_parameters;
},
lazy_storage_diff,
ctxt )
| Typed_tx_rollup {arg_ty = parameters_ty; tx_rollup = destination} ->
make_transaction_to_tx_rollup
ctxt
~destination
~amount
~parameters_ty
~parameters
>|=? fun (operation, ctxt) -> (operation, None, ctxt)
| Typed_sc_rollup
{arg_ty = parameters_ty; sc_rollup = destination; entrypoint} ->
make_transaction_to_sc_rollup
ctxt
~destination
~amount
~entrypoint
~parameters_ty
~parameters
>|=? fun (operation, ctxt) -> (operation, None, ctxt)
| Typed_zk_rollup {arg_ty = parameters_ty; zk_rollup = destination} ->
make_transaction_to_zk_rollup
ctxt
~destination
~amount
~parameters_ty
~parameters
>|=? fun (operation, ctxt) -> (operation, None, ctxt))
>>=? fun (operation, lazy_storage_diff, ctxt) ->
fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->
let iop = {source = Contract.Originated sc.self; operation; nonce} in
let res = {piop = Internal_operation iop; lazy_storage_diff} in
let gas, ctxt = local_gas_counter_and_outdated_context ctxt in
return (res, ctxt, gas)
(** [create_contract (ctxt, sc) gas storage_ty code delegate credit init]
creates an origination operation for a contract represented by [code], some
initial [credit] (withdrawn from the contract being executed), and an
initial storage [init] of type [storage_ty]. *)
let create_contract (ctxt, sc) gas storage_type code delegate credit init =
let ctxt = update_context gas ctxt in
collect_lazy_storage ctxt storage_type init >>?= fun (to_duplicate, ctxt) ->
let to_update = no_lazy_storage_id in
extract_lazy_storage_diff
ctxt
Optimized
storage_type
init
~to_duplicate
~to_update
~temporary:true
>>=? fun (init, lazy_storage_diff, ctxt) ->
unparse_data ctxt Optimized storage_type init
>>=? fun (unparsed_storage, ctxt) ->
Contract.fresh_contract_from_current_nonce ctxt
>>?= fun (ctxt, preorigination) ->
let operation =
Origination
{
credit;
delegate;
code;
unparsed_storage;
preorigination;
storage_type;
storage = init;
}
in
fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) ->
let source = Contract.Originated sc.self in
let piop = Internal_operation {source; operation; nonce} in
let res = {piop; lazy_storage_diff} in
let gas, ctxt = local_gas_counter_and_outdated_context ctxt in
return (res, preorigination, ctxt, gas)
(* [unpack ctxt ty bytes] deserialize [bytes] into a value of type [ty]. *)
let unpack ctxt ~ty ~bytes =
Gas.consume
ctxt
(Script.deserialization_cost_estimated_from_bytes (Bytes.length bytes))
>>?= fun ctxt ->
if
Compare.Int.(Bytes.length bytes >= 1)
&& Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05)
then
let str = Bytes.sub_string bytes 1 (Bytes.length bytes - 1) in
match Data_encoding.Binary.of_string_opt Script.expr_encoding str with
| None ->
Lwt.return
( Gas.consume ctxt (Interp_costs.unpack_failed str) >|? fun ctxt ->
(None, ctxt) )
| Some expr -> (
parse_data
ctxt
~elab_conf:Script_ir_translator_config.(make ~legacy:false ())
~allow_forged:false
ty
(Micheline.root expr)
>|= function
| Ok (value, ctxt) -> ok (Some value, ctxt)
| Error _ignored ->
Gas.consume ctxt (Interp_costs.unpack_failed str) >|? fun ctxt ->
(None, ctxt))
else return (None, ctxt)
(* [interp_stack_prefix_preserving_operation f w accu stack] applies
a well-typed operation [f] under some prefix of the A-stack
exploiting [w] to justify that the shape of the stack is
preserved. *)
let rec interp_stack_prefix_preserving_operation :
type a s b t c u d w result.
(a -> s -> (b * t) * result) ->
(a, s, b, t, c, u, d, w) stack_prefix_preservation_witness ->
c ->
u ->
(d * w) * result =
fun f n accu stk ->
match (n, stk) with
| KPrefix (_, _, n), rest ->
interp_stack_prefix_preserving_operation f n (fst rest) (snd rest)
|> fun ((v, rest'), result) -> ((accu, (v, rest')), result)
| KRest, v -> f accu v
(*
Some auxiliary functions have complex types and must be annotated
because of GADTs and polymorphic recursion.
To improve readibility, we introduce their types as abbreviations:
*)
(* A function of this type either introduces type-preserving
instrumentation of a continuation for the purposes of logging
or returns given continuation unchanged. *)
type ('a, 'b, 'c, 'd) cont_instrumentation =
('a, 'b, 'c, 'd) continuation -> ('a, 'b, 'c, 'd) continuation
let id x = x
type ('a, 'b, 'c, 'e, 'f, 'm, 'n, 'o) kmap_exit_type =
('a, 'b, 'e, 'f) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('m * 'n, 'a * 'b, 'o, 'a * 'b) kinstr ->
('m * 'n) list ->
(('m, 'o) map, 'c) ty option ->
('m, 'o) map ->
'm ->
(('m, 'o) map, 'a * 'b, 'e, 'f) continuation ->
'o ->
'a * 'b ->
('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'j, 'k) kmap_enter_type =
('a, 'b * 'c, 'd, 'e) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('j * 'k, 'b * 'c, 'a, 'b * 'c) kinstr ->
('j * 'k) list ->
(('j, 'a) map, 'f) ty option ->
('j, 'a) map ->
(('j, 'a) map, 'b * 'c, 'd, 'e) continuation ->
'b ->
'c ->
('d * 'e * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'i, 'j) klist_exit_type =
('a, 'b, 'c, 'd) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('i, 'a * 'b, 'j, 'a * 'b) kinstr ->
'i list ->
'j Script_list.t ->
('j Script_list.t, 'e) ty option ->
int ->
('j Script_list.t, 'a * 'b, 'c, 'd) continuation ->
'j ->
'a * 'b ->
('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'j) klist_enter_type =
('b, 'a * 'c, 'd, 'e) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('j, 'a * 'c, 'b, 'a * 'c) kinstr ->
'j list ->
'b Script_list.t ->
('b Script_list.t, 'f) ty option ->
int ->
('b Script_list.t, 'a * 'c, 'd, 'e) continuation ->
'a ->
'c ->
('d * 'e * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'g) kloop_in_left_type =
outdated_context * step_constants ->
local_gas_counter ->
('c, 'd, 'e, 'f) continuation ->
('a, 'g, 'c, 'd) kinstr ->
('b, 'g, 'e, 'f) continuation ->
('a, 'b) union ->
'g ->
('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'r, 'f, 's) kloop_in_type =
outdated_context * step_constants ->
local_gas_counter ->
('b, 'c, 'r, 'f) continuation ->
('a, 's, 'b, 'c) kinstr ->
('a, 's, 'r, 'f) continuation ->
bool ->
'a * 's ->
('r * 'f * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 's, 'r, 'f, 'c) kiter_type =
('a, 's, 'r, 'f) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('b, 'a * 's, 'a, 's) kinstr ->
('b, 'c) ty option ->
'b list ->
('a, 's, 'r, 'f) continuation ->
'a ->
's ->
('r * 'f * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i) ilist_map_type =
('a, 'b, 'c, 'd) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('e, 'a * 'b, 'f, 'a * 'b) kinstr ->
('f Script_list.t, 'a * 'b, 'g, 'h) kinstr ->
('g, 'h, 'c, 'd) continuation ->
('f Script_list.t, 'i) ty option ->
'e Script_list.t ->
'a * 'b ->
('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'cmp) ilist_iter_type =
('a, 'b, 'c, 'd) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('e, 'a * 'b, 'a, 'b) kinstr ->
('e, 'cmp) ty option ->
('a, 'b, 'f, 'g) kinstr ->
('f, 'g, 'c, 'd) continuation ->
'e Script_list.t ->
'a * 'b ->
('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'g) iset_iter_type =
('a, 'b, 'c, 'd) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('e, 'a * 'b, 'a, 'b) kinstr ->
'e comparable_ty option ->
('a, 'b, 'f, 'g) kinstr ->
('f, 'g, 'c, 'd) continuation ->
'e set ->
'a * 'b ->
('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'i, 'j) imap_map_type =
('a, 'b, 'c, 'd) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('e * 'f, 'a * 'b, 'g, 'a * 'b) kinstr ->
(('e, 'g) map, 'a * 'b, 'h, 'i) kinstr ->
('h, 'i, 'c, 'd) continuation ->
(('e, 'g) map, 'j) ty option ->
('e, 'f) map ->
'a * 'b ->
('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'cmp) imap_iter_type =
('a, 'b, 'c, 'd) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('e * 'f, 'a * 'b, 'a, 'b) kinstr ->
('e * 'f, 'cmp) ty option ->
('a, 'b, 'g, 'h) kinstr ->
('g, 'h, 'c, 'd) continuation ->
('e, 'f) map ->
'a * 'b ->
('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f) imul_teznat_type =
logger option ->
outdated_context * step_constants ->
local_gas_counter ->
Script.location ->
(Tez.t, 'b, 'c, 'd) kinstr ->
('c, 'd, 'e, 'f) continuation ->
Tez.t ->
Script_int.n Script_int.num * 'b ->
('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f) imul_nattez_type =
logger option ->
outdated_context * step_constants ->
local_gas_counter ->
Script.location ->
(Tez.t, 'b, 'c, 'd) kinstr ->
('c, 'd, 'e, 'f) continuation ->
Script_int.n Script_int.num ->
Tez.t * 'b ->
('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f) ilsl_nat_type =
logger option ->
outdated_context * step_constants ->
local_gas_counter ->
Script.location ->
(Script_int.n Script_int.num, 'b, 'c, 'd) kinstr ->
('c, 'd, 'e, 'f) continuation ->
Script_int.n Script_int.num ->
Script_int.n Script_int.num * 'b ->
('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f) ilsr_nat_type =
logger option ->
outdated_context * step_constants ->
local_gas_counter ->
Script.location ->
(Script_int.n Script_int.num, 'b, 'c, 'd) kinstr ->
('c, 'd, 'e, 'f) continuation ->
Script_int.n Script_int.num ->
Script_int.n Script_int.num * 'b ->
('e * 'f * outdated_context * local_gas_counter, error trace) result Lwt.t
type ifailwith_type = {
ifailwith :
'a 'ac 'b.
logger option ->
outdated_context * step_constants ->
local_gas_counter ->
Script.location ->
('a, 'ac) ty ->
'a ->
('b, error trace) result Lwt.t;
}
[@@unboxed]
type ('a, 'b, 'c, 'd, 'e, 'f, 'g) iexec_type =
('a, end_of_stack, 'e, 'f) cont_instrumentation ->
logger option ->
outdated_context * step_constants ->
local_gas_counter ->
('a, 'b) stack_ty option ->
('a, 'b, 'c, 'd) kinstr ->
('c, 'd, 'e, 'f) continuation ->
'g ->
('g, 'a) lambda * 'b ->
('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t
type ('a, 'b, 'c, 'd, 'e, 'f, 'i, 'o) iview_type =
('o, end_of_stack, 'e, 'f) cont_instrumentation ->
outdated_context * step_constants ->
local_gas_counter ->
('i, 'o) view_signature ->
('a, 'b) stack_ty option ->
('o option, 'a * 'b, 'c, 'd) kinstr ->
('c, 'd, 'e, 'f) continuation ->
'i ->
address * ('a * 'b) ->
('e * 'f * outdated_context * local_gas_counter) tzresult Lwt.t
