Source file script_interpreter_defs.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2021 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

(*

   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 (map, _) = stack in
      Interp_costs.big_map_mem map.diff
  | IBig_map_get _ ->
      let (map, _) = stack in
      Interp_costs.big_map_get map.diff
  | IBig_map_update _ ->
      let (_, (map, _)) = stack in
      Interp_costs.big_map_update map.diff
  | IBig_map_get_and_update _ ->
      let (_, (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 = 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_int _ ->
      let x = accu in
      Interp_costs.neg_int x
  | INeg_nat _ ->
      let x = accu in
      Interp_costs.neg_nat x
  | IAdd_intint _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.add_intint x y
  | IAdd_intnat _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.add_intnat x y
  | IAdd_natint _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.add_natint x y
  | IAdd_natnat _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.add_natnat x y
  | ISub_int _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.sub_int x y
  | IMul_intint _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.mul_intint x y
  | IMul_intnat _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.mul_intnat x y
  | IMul_natint _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.mul_natint x y
  | IMul_natnat _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.mul_natnat x y
  | IEdiv_teznat _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.ediv_teznat x y
  | IEdiv_intint _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.ediv_intint x y
  | IEdiv_intnat _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.ediv_intnat x y
  | IEdiv_natint _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.ediv_natint x y
  | IEdiv_natnat _ ->
      let x = accu and (y, _) = stack in
      Interp_costs.ediv_natnat 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
  | INot_nat _ ->
      let x = accu in
      Interp_costs.not_nat 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 = List.length tx.inputs in
      let outputs = List.length tx.outputs in
      Interp_costs.sapling_verify_update ~inputs ~outputs
  | ISplit_ticket _ ->
      let ticket = accu and ((amount_a, amount_b), _) = stack in
      Interp_costs.split_ticket ticket.amount 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
  | 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
  | 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 _ ->
      Interp_costs.apply
  | 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
  | IImplicit_account _ ->
      Interp_costs.implicit_account
  | ISet_delegate _ ->
      Interp_costs.set_delegate
  | IBalance _ ->
      Interp_costs.balance
  | ILevel _ ->
      Interp_costs.level
  | INow _ ->
      Interp_costs.now
  | 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 _ ->
      Interp_costs.ticket
  | IRead_ticket _ ->
      Interp_costs.read_ticket
  | 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
  | 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

(*

   Gas update and check for gas exhaustion
   =======================================

   Each instruction has a cost. The runtime subtracts this cost
   from an amount of gas made available for the script execution.

   Updating the gas counter is a critical aspect to Michelson
   execution because it is done at each execution step.

   For this reason, the interpreter must read and update the
   gas counter as quickly as possible. Hence, the gas counter
   should be stored in a machine register. To motivate the
   OCaml compiler to make that choice, we represent the gas
   counter as a local parameter of the execution [step]
   function.

*)

type local_gas_counter = int

(*

   The gas counter stored in the context is desynchronized with the
   [local_gas_counter] used in the interpretation loop. When we have
   to call a gas-consuming function which lives outside the
   interpreter, we must update the context so that it carries an
   up-to-date gas counter. Similarly, when we return from such a
   function, the [local_gas_counter] must be updated as well.

   To statically track these points where the context's gas counter
   must be updated, we introduce a type for outdated contexts. The
   [step] function carries an [outdated_context]. When an external
   function needs a [context], the typechecker points out the need for
   a conversion: this forces us to either call [update_context], or
   better, when this is possible, the function
   [use_gas_counter_in_ctxt].

*)
type outdated_context = OutDatedContext of context [@@unboxed]

let update_context local_gas_counter = function
  | OutDatedContext ctxt ->
      Gas.update_remaining_operation_gas
        ctxt
        (Saturation_repr.safe_int local_gas_counter)
  [@@ocaml.inline always]

let update_local_gas_counter ctxt =
  (Gas.remaining_operation_gas ctxt :> int)
  [@@ocaml.inline always]

let outdated ctxt = OutDatedContext ctxt [@@ocaml.inline always]

let context_from_outdated_context (OutDatedContext ctxt) =
  ctxt
  [@@ocaml.inline always]

let use_gas_counter_in_ctxt ctxt local_gas_counter f =
  let ctxt = update_context local_gas_counter ctxt in
  f ctxt
  >>=? fun (y, ctxt) -> return (y, outdated ctxt, update_local_gas_counter ctxt)
  [@@ocaml.inline always]

(*

   [step] calls [consume] at the beginning of each execution step.

   [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 update_and_check gas_counter (cost : Gas.cost) =
  let gas_counter = gas_counter - (cost :> int) in
  if Compare.Int.(gas_counter < 0) then None else Some gas_counter
  [@@ocaml.inline always]

let consume local_gas_counter k accu stack =
  let cost = cost_of_instr k accu stack in
  update_and_check local_gas_counter cost
  [@@ocaml.inline always]

let consume' ctxt local_gas_counter cost =
  match update_and_check local_gas_counter cost with
  | None ->
      Gas.gas_exhausted_error (update_context local_gas_counter ctxt)
  | Some local_gas_counter ->
      Ok local_gas_counter
  [@@ocaml.inline always]

let consume_control local_gas_counter ks =
  let cost = cost_of_control ks in
  update_and_check local_gas_counter cost
  [@@ocaml.inline always]

(*

   Auxiliary functions used by the instrumentation
   ===============================================

*)

let log_entry logger ctxt gas k accu stack =
  let kinfo = kinfo_of_kinstr k in
  let ctxt = update_context gas ctxt in
  logger.log_entry k ctxt kinfo.iloc kinfo.kstack_ty (accu, stack)

let log_exit logger ctxt gas kinfo_prev k accu stack =
  let kinfo = kinfo_of_kinstr k in
  let ctxt = update_context gas ctxt in
  logger.log_exit k ctxt kinfo_prev.iloc kinfo.kstack_ty (accu, stack)

let log_control logger ks = logger.log_control ks

let get_log = function
  | None ->
      Lwt.return (Ok None)
  | Some logger ->
      logger.get_log ()
  [@@ocaml.inline always]

(* [log_kinstr logger i] emits an instruction to instrument the
   execution of [i] with [logger]. *)
let log_kinstr logger i = ILog (kinfo_of_kinstr i, LogEntry, logger, i)

(* [log_next_kinstr logger i] instruments the next instruction of [i]
   with the [logger].

   Notice that the instrumentation breaks the sharing of continuations
   that is normally enforced between branches of conditionals. This
   has a performance cost. Anyway, the instrumentation allocates many
   new [ILog] instructions and [KLog] continuations which makes
   the execution of instrumented code significantly slower than
   non-instrumented code. "Zero-cost logging" means that the normal
   non-instrumented execution is not impacted by the ability to
   instrument it, not that the logging itself has no cost.

*)
let log_next_kinstr logger i =
  let apply k =
    ILog
      ( kinfo_of_kinstr k,
        LogExit (kinfo_of_kinstr i),
        logger,
        log_kinstr logger k )
  in
  kinstr_rewritek i {apply}

(* We pass the identity function when no instrumentation is needed. *)
let id x = x [@@inline]

(*

    Interpreter parameters
    ======================

*)
type step_constants = {
  source : Contract.t;
  payer : Contract.t;
  self : Contract.t;
  amount : Tez.t;
  chain_id : Chain_id.t;
}

(*

   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 (kinfo, w) ->
      let k = IConst (kinfo, 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 (Lam (descr, expr)) = lam in
  let (Item_t (full_arg_ty, _, _)) = descr.kbef in
  let ctxt = update_context gas ctxt 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, Bot_t, None) in
      let full_descr =
        {
          kloc = descr.kloc;
          kbef = arg_stack_ty;
          kaft = descr.kaft;
          kinstr =
            (let kinfo_const = {iloc = descr.kloc; kstack_ty = arg_stack_ty} in
             let kinfo_pair =
               {
                 iloc = descr.kloc;
                 kstack_ty = Item_t (capture_ty, arg_stack_ty, None);
               }
             in
             IConst
               (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr)));
        }
      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
      let gas = update_local_gas_counter ctxt in
      return (lam', outdated ctxt, gas)
  | _ ->
      assert false

(* [transfer (ctxt, sc) gas tez tp p destination entrypoint]
   creates an operation that transfers an amount of [tez] to
   a contract determined by [(destination, entrypoint)]
   instantiated with argument [p] of type [tp]. *)
let transfer (ctxt, sc) gas amount tp p destination entrypoint =
  let ctxt = update_context gas ctxt in
  collect_lazy_storage ctxt tp p
  >>?= fun (to_duplicate, ctxt) ->
  let to_update = no_lazy_storage_id in
  extract_lazy_storage_diff
    ctxt
    Optimized
    tp
    p
    ~to_duplicate
    ~to_update
    ~temporary:true
  >>=? fun (p, lazy_storage_diff, ctxt) ->
  unparse_data ctxt Optimized tp p
  >>=? fun (p, ctxt) ->
  Gas.consume ctxt (Script.strip_locations_cost p)
  >>?= fun ctxt ->
  let operation =
    Transaction
      {
        amount;
        destination;
        entrypoint;
        parameters = Script.lazy_expr (Micheline.strip_locations p);
      }
  in
  fresh_internal_nonce ctxt
  >>?= fun (ctxt, nonce) ->
  let iop = {source = sc.self; operation; nonce} in
  let res = (Internal_operation iop, lazy_storage_diff) in
  let gas = update_local_gas_counter ctxt in
  let ctxt = outdated ctxt in
  return (res, ctxt, gas)

(* [create_contract (ctxt, sc) gas storage_ty param_ty code root_name
   delegate credit init] creates an origination operation for a
   contract represented by [code], with some [root_name], some initial
   [credit] (taken to contract being executed), and an initial storage
   [init] of type [storage_ty]. The type of the new contract argument
   is [param_ty]. *)
let create_contract (ctxt, sc) gas storage_type param_type code root_name
    delegate credit init =
  let ctxt = update_context gas ctxt in
  unparse_ty ctxt param_type
  >>?= fun (unparsed_param_type, ctxt) ->
  let unparsed_param_type =
    Script_ir_translator.add_field_annot 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_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 (storage, ctxt) ->
  Gas.consume ctxt (Script.strip_locations_cost storage)
  >>?= fun 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
  fresh_internal_nonce ctxt
  >>?= fun (ctxt, nonce) ->
  let res =
    (Internal_operation {source = sc.self; operation; nonce}, lazy_storage_diff)
  in
  let gas = update_local_gas_counter ctxt in
  let ctxt = outdated ctxt in
  return (res, contract, 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 bytes = Bytes.sub bytes 1 (Bytes.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 -> (None, ctxt) )
    | Some expr -> (
        parse_data
          ctxt
          ~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 bytes)
            >|? 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:

*)

type ('a, 's, 'b, 't, 'r, 'f) step_type =
  outdated_context * step_constants ->
  local_gas_counter ->
  ('a, 's, 'b, 't) kinstr ->
  ('b, 't, 'r, 'f) continuation ->
  'a ->
  's ->
  ('r * 'f * outdated_context * local_gas_counter) tzresult Lwt.t

type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h, 'm, 'n, 'o) kmap_exit_type =
  (('c, 'd, 'e, 'f) continuation -> ('a, 'b, 'g, 'h) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('m * 'n, 'c * 'd, 'o, 'c * 'd) kinstr * ('m * 'n) list * ('m, 'o) map * 'm ->
  (('m, 'o) map, 'c * 'd, 'e, 'f) continuation ->
  'o ->
  'a * 'b ->
  ('g * 'h * outdated_context * local_gas_counter) tzresult Lwt.t

type ('a, 'b, 'c, 'd, 'e, 'j, 'k) kmap_enter_type =
  (('a, 'b * 'c, 'd, 'e) continuation -> ('a, 'b * 'c, 'd, 'e) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('j * 'k, 'b * 'c, 'a, 'b * 'c) kinstr * ('j * 'k) list * ('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, 'i, 'j) klist_exit_type =
  (('a, 'b, 'c, 'd) continuation -> ('a, 'b, 'c, 'd) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('i, 'a * 'b, 'j, 'a * 'b) kinstr * 'i list * 'j list * local_gas_counter ->
  ('j boxed_list, 'a * 'b, 'c, 'd) continuation ->
  'j ->
  'a * 'b ->
  ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t

type ('a, 'b, 'c, 'd, 'e, 'j) klist_enter_type =
  (('b, 'a * 'c, 'd, 'e) continuation -> ('b, 'a * 'c, 'd, 'e) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('j, 'a * 'c, 'b, 'a * 'c) kinstr * 'j list * 'b list * local_gas_counter ->
  ('b boxed_list, '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) kiter_type =
  (('a, 's, 'r, 'f) continuation -> ('a, 's, 'r, 'f) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('b, 'a * 's, 'a, 's) kinstr * '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) ilist_map_type =
  (('a, 'b, 'c, 'd) continuation -> ('a, 'b, 'c, 'd) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('e, 'a * 'b, 'f, 'a * 'b) kinstr * ('f boxed_list, 'a * 'b, 'g, 'h) kinstr ->
  ('g, 'h, 'c, 'd) continuation ->
  'e boxed_list ->
  'a * 'b ->
  ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t

type ('a, 'b, 'c, 'd, 'e, 'f, 'g) ilist_iter_type =
  (('a, 'b, 'c, 'd) continuation -> ('a, 'b, 'c, 'd) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('e, 'a * 'b, 'a, 'b) kinstr * ('a, 'b, 'f, 'g) kinstr ->
  ('f, 'g, 'c, 'd) continuation ->
  'e boxed_list ->
  '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) continuation -> ('a, 'b, 'c, 'd) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('e, 'a * 'b, 'a, 'b) kinstr * ('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) imap_map_type =
  (('a, 'b, 'c, 'd) continuation -> ('a, 'b, 'c, 'd) continuation) ->
  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, 'f) map ->
  'a * 'b ->
  ('c * 'd * outdated_context * local_gas_counter) tzresult Lwt.t

type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) imap_iter_type =
  (('a, 'b, 'c, 'd) continuation -> ('a, 'b, 'c, 'd) continuation) ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('e * 'f, 'a * 'b, 'a, 'b) kinstr * ('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 ->
  (Tez.t, 'a) kinfo * (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_int.n Script_int.num, 'a) kinfo * (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_int.n Script_int.num, 'a) kinfo
  * (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_int.n Script_int.num, 'a) kinfo
  * (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) ifailwith_type =
  logger option ->
  outdated_context * step_constants ->
  local_gas_counter ->
  int ->
  'a ty ->
  'a ->
  ('b, error trace) result Lwt.t

type ('a, 'b, 'c, 'd, 'e, 'f, 'g) iexec_type =
  logger option ->
  outdated_context * step_constants ->
  local_gas_counter ->
  ('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