From 769d170559ba0e8e28d018a3e642fd6a469ccc26 Mon Sep 17 00:00:00 2001 From: Docker Date: Tue, 23 Aug 2022 11:01:00 +0100 Subject: [PATCH 1/3] Proto: changes for proto J for coq-of-ocaml --- .../bin_sc_rollup_node/store.ml | 2 + .../client_baking_denunciation.ml | 6 +- .../lib_injector/injector_functor.ml | 2 +- src/proto_013_PtJakart/lib_plugin/plugin.ml | 15 +- .../lib_protocol/alpha_context.ml | 16 +- .../lib_protocol/alpha_context.mli | 142 +- src/proto_013_PtJakart/lib_protocol/apply.ml | 208 +-- .../lib_protocol/apply_results.ml | 405 ++--- .../lib_protocol/apply_results.mli | 3 +- src/proto_013_PtJakart/lib_protocol/baking.ml | 2 +- .../lib_protocol/bootstrap_storage.ml | 11 +- .../lib_protocol/cache_repr.ml | 20 +- .../lib_protocol/carbonated_map.ml | 2 +- .../lib_protocol/contract_services.ml | 45 +- .../lib_protocol/contract_storage.ml | 82 +- .../lib_protocol/delegate_storage.ml | 48 +- .../lib_protocol/dependent_bool.ml | 4 +- .../lib_protocol/dependent_bool.mli | 2 +- .../lib_protocol/fees_storage.ml | 4 +- .../lib_protocol/fitness_repr.ml | 8 +- .../lib_protocol/gas_comparable_input_size.ml | 60 +- .../lib_protocol/gas_input_size.ml | 2 +- .../lib_protocol/gas_monad.ml | 18 +- .../lib_protocol/global_constants_storage.ml | 42 +- .../lib_protocol/indexable.ml | 75 +- .../lib_protocol/indexable.mli | 16 +- .../lib_protocol/init_storage.ml | 4 +- .../lib_protocol/lazy_storage_diff.ml | 36 +- .../lib_protocol/lazy_storage_kind.ml | 49 +- .../legacy_script_patches_for_J.ml | 8 +- .../lib_protocol/level_repr.ml | 3 +- .../lib_protocol/level_storage.ml | 4 +- .../liquidity_baking_migration.ml | 8 +- src/proto_013_PtJakart/lib_protocol/main.ml | 2 +- .../lib_protocol/merkle_list.ml | 57 +- .../lib_protocol/merkle_list.mli | 7 +- .../lib_protocol/michelson_v1_gas.ml | 160 +- .../lib_protocol/michelson_v1_primitives.ml | 16 +- src/proto_013_PtJakart/lib_protocol/misc.ml | 39 +- .../lib_protocol/operation_repr.ml | 359 +++-- .../lib_protocol/operation_repr.mli | 243 +-- .../lib_protocol/raw_context.ml | 72 +- .../lib_protocol/raw_context.mli | 2 + .../lib_protocol/raw_context_intf.ml | 214 +-- .../lib_protocol/round_repr.ml | 2 +- .../lib_protocol/sampler.ml | 2 +- .../lib_protocol/sapling_repr.ml | 2 + .../lib_protocol/sapling_storage.ml | 4 +- .../lib_protocol/sc_rollup_arith.ml | 48 +- .../lib_protocol/sc_rollup_game.ml | 2 +- .../lib_protocol/sc_rollup_inbox_repr.ml | 22 +- .../lib_protocol/sc_rollup_inbox_repr.mli | 2 + .../lib_protocol/sc_rollup_repr.ml | 9 +- .../lib_protocol/sc_rollup_repr.mli | 5 +- .../lib_protocol/sc_rollup_storage.ml | 64 +- .../lib_protocol/sc_rollup_tick_repr.ml | 26 +- .../lib_protocol/script_comparable.ml | 82 +- .../lib_protocol/script_int_repr.ml | 2 +- .../lib_protocol/script_int_repr.mli | 2 +- .../lib_protocol/script_interpreter.ml | 1022 +++++++----- .../lib_protocol/script_interpreter.mli | 2 +- .../lib_protocol/script_interpreter_defs.ml | 518 +++---- .../lib_protocol/script_ir_annot.ml | 2 +- .../lib_protocol/script_ir_translator.ml | 1379 ++++++++++------- .../lib_protocol/script_ir_translator.mli | 2 + .../lib_protocol/script_map.ml | 28 +- .../lib_protocol/script_repr.ml | 14 +- .../lib_protocol/script_set.ml | 16 +- .../lib_protocol/script_string_repr.ml | 2 +- .../lib_protocol/script_typed_ir.ml | 315 ++-- .../lib_protocol/script_typed_ir.mli | 11 +- .../lib_protocol/script_typed_ir_size.ml | 216 +-- .../lib_protocol/seed_repr.ml | 6 +- .../lib_protocol/services_registration.ml | 20 +- .../lib_protocol/services_registration.mli | 6 +- .../lib_protocol/skip_list_repr.ml | 73 +- .../lib_protocol/skip_list_repr.mli | 13 +- .../lib_protocol/slot_repr.ml | 6 +- .../lib_protocol/storage.ml | 79 +- .../lib_protocol/storage_description.ml | 133 +- .../lib_protocol/storage_functors.ml | 19 +- .../michelson/test_interpretation.ml | 4 +- .../operations/test_combined_operations.ml | 9 +- .../integration/operations/test_tx_rollup.ml | 16 +- .../test/integration/test_frozen_bonds.ml | 85 +- .../test/integration/test_token.ml | 435 ++++-- .../test/unit/test_tx_rollup_l2.ml | 11 +- .../lib_protocol/ticket_accounting.ml | 16 +- .../lib_protocol/ticket_hash_builder.ml | 10 +- .../lib_protocol/ticket_hash_repr.ml | 29 +- .../lib_protocol/ticket_lazy_storage_diff.ml | 27 +- .../lib_protocol/ticket_operations_diff.ml | 27 +- .../lib_protocol/ticket_scanner.ml | 79 +- .../lib_protocol/ticket_scanner.mli | 2 +- src/proto_013_PtJakart/lib_protocol/token.ml | 147 +- src/proto_013_PtJakart/lib_protocol/token.mli | 58 +- .../lib_protocol/tx_rollup_commitment_repr.ml | 8 +- .../tx_rollup_commitment_repr.mli | 2 +- .../tx_rollup_commitment_storage.ml | 30 +- .../tx_rollup_commitment_storage.mli | 7 +- .../lib_protocol/tx_rollup_errors_repr.ml | 28 +- .../lib_protocol/tx_rollup_gas.ml | 2 +- .../lib_protocol/tx_rollup_l2_apply.ml | 186 ++- .../lib_protocol/tx_rollup_l2_apply.mli | 143 +- .../lib_protocol/tx_rollup_l2_batch.ml | 24 +- .../lib_protocol/tx_rollup_l2_batch.mli | 16 +- .../lib_protocol/tx_rollup_l2_context.ml | 29 +- .../lib_protocol/tx_rollup_l2_context_sig.ml | 300 ++-- .../lib_protocol/tx_rollup_l2_storage_sig.ml | 62 +- .../lib_protocol/tx_rollup_l2_verifier.ml | 4 +- .../lib_protocol/tx_rollup_message_repr.ml | 3 +- .../lib_protocol/tx_rollup_parameters.ml | 6 +- .../lib_protocol/tx_rollup_repr.ml | 4 +- .../lib_protocol/tx_rollup_state_repr.ml | 2 +- .../lib_protocol/tx_rollup_ticket.ml | 10 +- .../lib_protocol/voting_services.ml | 3 - 116 files changed, 4923 insertions(+), 3580 deletions(-) diff --git a/src/proto_013_PtJakart/bin_sc_rollup_node/store.ml b/src/proto_013_PtJakart/bin_sc_rollup_node/store.ml index a528546ee8c39..0f8671ccabdb5 100644 --- a/src/proto_013_PtJakart/bin_sc_rollup_node/store.ml +++ b/src/proto_013_PtJakart/bin_sc_rollup_node/store.ml @@ -128,6 +128,8 @@ module IStoreTree = struct type key = path type value = bytes + + let __infer_t (_ : t) = () end module Inbox = Sc_rollup.Inbox.MakeHashingScheme (IStoreTree) diff --git a/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml b/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml index e29280816b7fd..b130171e0a12b 100644 --- a/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_013_PtJakart/lib_delegate/client_baking_denunciation.ml @@ -114,7 +114,7 @@ let get_block_offset level = Events.(emit invalid_level_conversion) (Environment.wrap_tztrace errs) >>= fun () -> Lwt.return (`Head 0) -let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) +let get_payload_hash (type kind) (op_kind : kind Consensus_operation_type.t) (op : kind Operation.t) = match (op_kind, op.protocol_data.contents) with | Preendorsement, Single (Preendorsement consensus_content) @@ -123,7 +123,7 @@ let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) | _ -> . let double_consensus_op_evidence (type kind) : - kind consensus_operation_type -> + kind Consensus_operation_type.t -> #Protocol_client_context.full -> 'a -> branch:Block_hash.t -> @@ -135,7 +135,7 @@ let double_consensus_op_evidence (type kind) : | Preendorsement -> Plugin.RPC.Forge.double_preendorsement_evidence let process_consensus_op (type kind) cctxt - (op_kind : kind consensus_operation_type) (new_op : kind Operation.t) + (op_kind : kind Consensus_operation_type.t) (new_op : kind Operation.t) chain_id level round slot ops_table = let map = Option.value ~default:Slot_Map.empty diff --git a/src/proto_013_PtJakart/lib_injector/injector_functor.ml b/src/proto_013_PtJakart/lib_injector/injector_functor.ml index 0792b7f73634e..8c4efa61bd75e 100644 --- a/src/proto_013_PtJakart/lib_injector/injector_functor.ml +++ b/src/proto_013_PtJakart/lib_injector/injector_functor.ml @@ -541,7 +541,7 @@ module Make (Rollup : PARAMETERS) = struct let* packed_op, result = simulate_operations ~must_succeed state operations in - let results = Apply_results.to_list result in + let results = Apply_results.packed_contents_result_list_to_list result in let failure = ref false in let* rev_non_failing_operations = List.fold_left2_s diff --git a/src/proto_013_PtJakart/lib_plugin/plugin.ml b/src/proto_013_PtJakart/lib_plugin/plugin.ml index 38f737f8b7a01..44b256a96b4f7 100644 --- a/src/proto_013_PtJakart/lib_plugin/plugin.ml +++ b/src/proto_013_PtJakart/lib_plugin/plugin.ml @@ -1592,7 +1592,7 @@ module RPC = struct let register0_fullctxt ~chunked s f = patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = @@ -1602,7 +1602,8 @@ module RPC = struct patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> let mode = - if q#successor_level then `Successor_level else `Head_level + if q#successor_level then Services_registration.Successor_level + else Head_level in Services_registration.rpc_init ctxt mode >>=? fun ctxt -> f ctxt q i) @@ -1617,7 +1618,7 @@ module RPC = struct let opt_register0_fullctxt ~chunked s f = patched_services := RPC_directory.opt_register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = @@ -1630,7 +1631,7 @@ module RPC = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = @@ -1643,7 +1644,7 @@ module RPC = struct !patched_services s (fun ((ctxt, arg1), arg2) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = @@ -2321,8 +2322,8 @@ module RPC = struct Token.transfer ~origin:Simulation ctxt - `Minted - (`Contract dummy_contract) + (Source_infinite Minted) + (Sink_container (Contract dummy_contract)) balance >>=? fun (ctxt, _) -> return (ctxt, dummy_contract) in diff --git a/src/proto_013_PtJakart/lib_protocol/alpha_context.ml b/src/proto_013_PtJakart/lib_protocol/alpha_context.ml index 3e557667a5044..a8731d3613ca6 100644 --- a/src/proto_013_PtJakart/lib_protocol/alpha_context.ml +++ b/src/proto_013_PtJakart/lib_protocol/alpha_context.ml @@ -150,7 +150,6 @@ end module Round = struct include Round_repr - module Durations = Durations type round_durations = Durations.t @@ -308,7 +307,12 @@ module Big_map = struct let unparse_to_z = Big_map.Id.unparse_to_z end - let fresh ~temporary c = Lazy_storage.fresh Big_map ~temporary c + let fresh ~temporary c = + (Lazy_storage.fresh + [@coq_implicit "a" "Big_map.alloc"] [@coq_implicit "u" "Big_map.updates"]) + Big_map + ~temporary + c let mem c m k = Storage.Big_map.Contents.mem (c, m) k @@ -358,7 +362,13 @@ module Sapling = struct include Sapling_storage include Sapling_validator - let fresh ~temporary c = Lazy_storage.fresh Sapling_state ~temporary c + let fresh ~temporary c = + (Lazy_storage.fresh + [@coq_implicit "a" "Sapling_state.alloc"] + [@coq_implicit "u" "Sapling_state.updates"]) + Sapling_state + ~temporary + c type updates = Sapling_state.updates diff --git a/src/proto_013_PtJakart/lib_protocol/alpha_context.mli b/src/proto_013_PtJakart/lib_protocol/alpha_context.mli index 6e8cacf9dcddf..1666e75899afc 100644 --- a/src/proto_013_PtJakart/lib_protocol/alpha_context.mli +++ b/src/proto_013_PtJakart/lib_protocol/alpha_context.mli @@ -101,9 +101,9 @@ module Slot : sig end module Tez : sig - type repr + type repr = Tez_repr.repr - type t = Tez_tag of repr [@@ocaml.unboxed] + type t = Tez_repr.t = Tez_tag of repr [@@ocaml.unboxed] include BASIC_DATA with type t := t @@ -1271,7 +1271,7 @@ module Big_map : sig Id.t -> (context * Script.expr list) tzresult Lwt.t - type update = { + type update = Lazy_storage_kind.Big_map.update = { key : Script_repr.expr; key_hash : Script_expr_hash.t; value : Script_repr.expr option; @@ -1279,7 +1279,10 @@ module Big_map : sig type updates = update list - type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr} + type alloc = Lazy_storage_kind.Big_map.alloc = { + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } end module Sapling : sig @@ -1306,7 +1309,7 @@ module Sapling : sig val diff_encoding : diff Data_encoding.t module Memo_size : sig - type t + type t = Sapling_repr.Memo_size.t val encoding : t Data_encoding.t @@ -1359,7 +1362,7 @@ module Sapling : sig string -> (context * (Int64.t * state) option) tzresult Lwt.t - type alloc = {memo_size : Memo_size.t} + type alloc = Lazy_storage_kind.Sapling_state.alloc = {memo_size : Memo_size.t} type updates = diff @@ -1456,7 +1459,7 @@ end (** This module re-exports functions from {!Ticket_hash_repr}. See documentation of the functions there. *) module Ticket_hash : sig - type t + type t = Ticket_hash_repr.t val encoding : t Data_encoding.t @@ -1672,9 +1675,10 @@ module Tx_rollup_withdraw : sig val encoding : t Data_encoding.t end +[@@coq_plain_module] module Tx_rollup_withdraw_list_hash : sig - include S.HASH + include S.HASH with type t = Tx_rollup_withdraw_list_hash_repr.t val hash_uncarbonated : Tx_rollup_withdraw.t list -> t @@ -1811,7 +1815,7 @@ end (** This module re-exports definitions from {!Tx_rollup_message_repr}. *) module Tx_rollup_message : sig - type deposit = { + type deposit = Tx_rollup_message_repr.deposit = { sender : public_key_hash; destination : Tx_rollup_l2_address.Indexable.value; ticket_hash : Ticket_hash.t; @@ -1958,11 +1962,14 @@ module Tx_rollup_commitment : sig val compact : t -> Compact.t end + type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : context -> Compact.t -> - [ `Hash of Tx_rollup_message_result_hash.t - | `Result of Tx_rollup_message_result.t ] -> + hash_or_result -> path:Merkle.path -> index:int -> context tzresult @@ -2071,6 +2078,12 @@ module Tx_rollup_hash : sig end module Tx_rollup_errors : sig + type error_or_commitment = Inbox | Commitment + + type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment.Merkle.h * int + | Hash of Tx_rollup_message_result_hash.t + type error += | Tx_rollup_already_exists of Tx_rollup.t | Tx_rollup_does_not_exist of Tx_rollup.t @@ -2107,7 +2120,7 @@ module Tx_rollup_errors : sig length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -2126,9 +2139,7 @@ module Tx_rollup_errors : sig } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash.t; - expected : - [ `Valid_path of Tx_rollup_commitment.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash.t ]; + expected : valid_path_or_hash; } | Wrong_deposit_parameters | Proof_failed_to_reject @@ -2140,7 +2151,7 @@ module Tx_rollup_errors : sig | No_withdrawals_to_dispatch val check_path_depth : - [`Inbox | `Commitment] -> int -> count_limit:int -> unit tzresult + error_or_commitment -> int -> count_limit:int -> unit tzresult end module Bond_id : sig @@ -2311,7 +2322,10 @@ module Delegate : sig endorsing_power:int -> context tzresult Lwt.t - type deposits = {initial_amount : Tez.t; current_amount : Tez.t} + type deposits = Storage.deposits = { + initial_amount : Tez.t; + current_amount : Tez.t; + } val frozen_deposits : context -> public_key_hash -> deposits tzresult Lwt.t @@ -2471,7 +2485,7 @@ module Sc_rollup : sig module Map : Map.S with type key = t end - module Address : S.HASH + module Address : S.HASH [@@coq_plain_module] type t = Address.t @@ -2480,13 +2494,14 @@ module Sc_rollup : sig val encoding : t Data_encoding.t end + [@@coq_plain_module] module Staker : S.SIGNATURE_PUBLIC_KEY_HASH with type t = Signature.Public_key_hash.t - module Commitment_hash : S.HASH + module Commitment_hash : S.HASH [@@coq_plain_module] - module State_hash : S.HASH + module State_hash : S.HASH [@@coq_plain_module] module Number_of_messages : Bounded.Int32.S @@ -2594,6 +2609,8 @@ module Sc_rollup : sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end module MakeHashingScheme (Tree : TREE) : @@ -2858,12 +2875,13 @@ module Kind : sig | Sc_rollup_publish_manager_kind : sc_rollup_publish manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot.t; @@ -3081,13 +3099,13 @@ module Operation : sig type nonrec packed_protocol_data = packed_protocol_data - type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t + module Consensus_watermark : sig + type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t + end - val to_watermark : consensus_watermark -> Signature.watermark + val to_watermark : Consensus_watermark.t -> Signature.watermark - val of_watermark : Signature.watermark -> consensus_watermark option + val of_watermark : Signature.watermark -> Consensus_watermark.t option val protocol_data_encoding : packed_protocol_data Data_encoding.t @@ -3461,34 +3479,38 @@ end (** See 'token.mli' for more explanation. *) module Token : sig type container = - [ `Contract of Contract.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract.t * Bond_id.t ] + | Contract of Contract.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract.t * Bond_id.t + + type infinite_source = + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards type source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards - | container ] - - type sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Burned - | `Tx_rollup_rejection_punishments - | container ] + | Source_infinite of infinite_source + | Source_container of container + + type infinite_sink = + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Burned + | Tx_rollup_rejection_punishments + + type sink = Sink_infinite of infinite_sink | Sink_container of container val allocated : context -> container -> (context * bool) tzresult Lwt.t @@ -3497,15 +3519,15 @@ module Token : sig val transfer_n : ?origin:Receipt.update_origin -> context -> - ([< source] * Tez.t) list -> - [< sink] -> + (source * Tez.t) list -> + sink -> (context * Receipt.balance_updates) tzresult Lwt.t val transfer : ?origin:Receipt.update_origin -> context -> - [< source] -> - [< sink] -> + source -> + sink -> Tez.t -> (context * Receipt.balance_updates) tzresult Lwt.t end diff --git a/src/proto_013_PtJakart/lib_protocol/apply.ml b/src/proto_013_PtJakart/lib_protocol/apply.ml index dd33934423cdf..3c4b3ea05c387 100644 --- a/src/proto_013_PtJakart/lib_protocol/apply.ml +++ b/src/proto_013_PtJakart/lib_protocol/apply.ml @@ -958,7 +958,11 @@ let apply_transaction ~ctxt ~parameter ~source ~contract ~amount ~entrypoint the next transfer of tokens will allocate it. *) Contract.allocated ctxt contract >|=? not) >>=? fun allocated_destination_contract -> - Token.transfer ctxt (`Contract source) (`Contract contract) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt contract >>=? fun (ctxt, cache_key, script) -> match script with @@ -1058,8 +1062,8 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~amount Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost -> Token.transfer ctxt - (`Contract (Contract.implicit_contract payer)) - `Burned + (Source_container (Contract (Contract.implicit_contract payer))) + (Sink_infinite Burned) cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_inbox.append_message ctxt dst_rollup state deposit @@ -1115,7 +1119,11 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code ~contract | None -> return ctxt | Some delegate -> Delegate.init ctxt contract delegate) >>=? fun ctxt -> - Token.transfer ctxt (`Contract source) (`Contract contract) credit + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + credit >>=? fun (ctxt, balance_updates) -> Fees.record_paid_storage_space ctxt contract >|=? fun (ctxt, size, paid_storage_size_diff) -> @@ -1322,7 +1330,7 @@ let apply_external_manager_operation_content : List.fold_left_es (fun (acc_withdraw, acc, ctxt) Tx_rollup_reveal.{contents; ty; ticketer; amount; claimer} -> - error_when + error_when Tx_rollup_l2_qty.(amount <= zero) Forbidden_zero_ticket_quantity >>?= fun () -> @@ -1350,7 +1358,7 @@ let apply_external_manager_operation_content : Tx_rollup_commitment.check_message_result ctxt commitment.commitment - (`Result {context_hash; withdraw_list_hash}) + (Result {context_hash; withdraw_list_hash}) ~path:message_result_path ~index:message_index >>?= fun ctxt -> @@ -1392,7 +1400,7 @@ let apply_external_manager_operation_content : in return (ctxt, result, []) | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} -> - (* The encoding ensures that the amount is in a natural number. Here is + (* The encoding ensures that the amount is in a natural number. Here is mainly to check that it is non-zero.*) error_when Compare.Z.(amount <= Z.zero) Forbidden_zero_ticket_quantity >>?= fun () -> @@ -1546,7 +1554,11 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, state, paid_storage_size_diff) -> Tx_rollup_state.burn_cost ~limit:burn_limit state message_size >>?= fun cost -> - Token.transfer ctxt (`Contract source_contract) `Burned cost + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_infinite Burned) + cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt -> let result = @@ -1566,8 +1578,8 @@ let apply_external_manager_operation_content : let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in Token.transfer ctxt - (`Contract source_contract) - (`Frozen_bonds (source_contract, bond_id)) + (Source_container (Contract source_contract)) + (Sink_container (Frozen_bonds (source_contract, bond_id))) (Constants.tx_rollup_commitment_bond ctxt) else return (ctxt, []) ) >>=? fun (ctxt, balance_updates) -> @@ -1580,12 +1592,12 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, slashed) -> if slashed then let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn else return (ctxt, []) | None -> return (ctxt, [])) @@ -1602,12 +1614,12 @@ let apply_external_manager_operation_content : | Tx_rollup_return_bond {tx_rollup} -> Tx_rollup_commitment.remove_bond ctxt tx_rollup source >>=? fun ctxt -> let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (source_contract, bond_id)) + Token.balance ctxt (Frozen_bonds (source_contract, bond_id)) >>=? fun (ctxt, bond) -> Token.transfer ctxt - (`Frozen_bonds (source_contract, bond_id)) - (`Contract source_contract) + (Source_container (Frozen_bonds (source_contract, bond_id))) + (Sink_container (Contract source_contract)) bond >>=? fun (ctxt, balance_updates) -> let result = @@ -1723,19 +1735,19 @@ let apply_external_manager_operation_content : (if slashed then let committer = Contract.implicit_contract commitment.committer in let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Tez.(burn /? 2L) >>?= fun reward -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn >>=? fun (ctxt, burn_update) -> Token.transfer ctxt - `Tx_rollup_rejection_rewards - (`Contract source_contract) + (Source_infinite Tx_rollup_rejection_rewards) + (Sink_container (Contract source_contract)) reward >>=? fun (ctxt, reward_update) -> return (ctxt, burn_update @ reward_update) @@ -1934,7 +1946,7 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) Constants.parametric ctxt in Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> @@ -1968,17 +1980,17 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) Constants.parametric ctxt in Tx_rollup_errors.check_path_depth - `Inbox + Inbox (Tx_rollup_inbox.Merkle.path_depth message_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth previous_message_result_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> return ctxt @@ -1987,7 +1999,11 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) assert_sc_rollup_feature_enabled ctxt >|=? fun () -> ctxt) >>=? fun ctxt -> Contract.increment_counter ctxt source >>=? fun ctxt -> - Token.transfer ctxt (`Contract source_contract) `Block_fees fee + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_container Block_fees) + fee >|=? fun (ctxt, balance_updates) -> let consumed_gas = Gas.consumed ~since:ctxt_before ~until:ctxt in (ctxt, {balance_updates; consumed_gas}) @@ -2005,7 +2021,9 @@ let burn_storage_fees : payer:public_key_hash -> (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t = fun ctxt smopr ~storage_limit ~payer -> - let payer = `Contract (Contract.implicit_contract payer) in + let payer = + Token.Source_container (Contract (Contract.implicit_contract payer)) + in match smopr with | Transaction_result (Transaction_to_contract_result payload) -> let consumed = payload.paid_storage_size_diff in @@ -2412,49 +2430,49 @@ let rec apply_manager_contents_list_rec : >|= fun (ctxt_result, results) -> (ctxt_result, Cons_result (result, results))) -let mark_backtracked results = - let rec mark_contents_list : - type kind. - kind Kind.manager contents_result_list -> - kind Kind.manager contents_result_list = function - | Single_result (Manager_operation_result op) -> - Single_result - (Manager_operation_result - { - balance_updates = op.balance_updates; - operation_result = - mark_manager_operation_result op.operation_result; - internal_operation_results = - List.map - mark_internal_operation_results - op.internal_operation_results; - }) - | Cons_result (Manager_operation_result op, rest) -> - Cons_result - ( Manager_operation_result - { - balance_updates = op.balance_updates; - operation_result = - mark_manager_operation_result op.operation_result; - internal_operation_results = - List.map - mark_internal_operation_results - op.internal_operation_results; - }, - mark_contents_list rest ) - and mark_internal_operation_results - (Internal_manager_operation_result (kind, result)) = - Internal_manager_operation_result - (kind, mark_manager_operation_result result) - and mark_manager_operation_result : - type kind. kind manager_operation_result -> kind manager_operation_result - = function - | (Failed _ | Skipped _ | Backtracked _) as result -> result - | Applied (Reveal_result _) as result -> result - | Applied result -> Backtracked (result, None) - in - mark_contents_list results - [@@coq_axiom_with_reason "non-top-level mutual recursion"] +let[@coq_struct "function_parameter"] rec mark_contents_list_aux : + type kind. + kind Kind.manager contents_result_list -> + kind Kind.manager contents_result_list = + function[@coq_match_gadt_with_result] [@coq_match_with_default] + | Single_result (Manager_operation_result op) -> + Single_result + (Manager_operation_result + { + balance_updates = op.balance_updates; + operation_result = + mark_manager_operation_result op.operation_result; + internal_operation_results = + List.map + mark_internal_operation_results + op.internal_operation_results; + }) + | Cons_result (Manager_operation_result op, rest) -> + Cons_result + ( Manager_operation_result + { + balance_updates = op.balance_updates; + operation_result = + mark_manager_operation_result op.operation_result; + internal_operation_results = + List.map + mark_internal_operation_results + op.internal_operation_results; + }, + mark_contents_list_aux rest ) + +and mark_internal_operation_results + (Internal_manager_operation_result (kind, result)) = + Internal_manager_operation_result (kind, mark_manager_operation_result result) + +and mark_manager_operation_result : + type kind. kind manager_operation_result -> kind manager_operation_result = + function + | (Failed _ | Skipped _ | Backtracked _) as result -> result + | Applied (Reveal_result _) as result -> result + | Applied result -> Backtracked (result, None) + +let mark_backtracked results = mark_contents_list_aux results type apply_mode = | Application of { @@ -2485,7 +2503,7 @@ let get_predecessor_level = function predecessor_level let record_operation (type kind) ctxt (operation : kind operation) : context = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> ctxt | Single (Endorsement _) -> ctxt | Single @@ -2509,7 +2527,7 @@ type 'consensus_op_kind expected_consensus_content = { let compute_expected_consensus_content (type consensus_op_kind) ~(current_level : Level.t) ~(proposal_level : Level.t) (ctxt : context) (application_mode : apply_mode) - (operation_kind : consensus_op_kind consensus_operation_type) + (operation_kind : consensus_op_kind Consensus_operation_type.t) (operation_round : Round.t) (operation_level : Raw_level.t) : (context * consensus_op_kind expected_consensus_content) tzresult Lwt.t = match operation_kind with @@ -2614,7 +2632,7 @@ let check_operation_branch ~expected ~provided = (Block_hash.equal expected provided) (Wrong_consensus_operation_branch (expected, provided)) -let check_round (type kind) (operation_kind : kind consensus_operation_type) +let check_round (type kind) (operation_kind : kind Consensus_operation_type.t) (apply_mode : apply_mode) ~(expected : Round.t) ~(provided : Round.t) : unit tzresult = match apply_mode with @@ -2640,7 +2658,7 @@ let check_round (type kind) (operation_kind : kind consensus_operation_type) let check_consensus_content (type kind) (apply_mode : apply_mode) (content : consensus_content) (operation_branch : Block_hash.t) - (operation_kind : kind consensus_operation_type) + (operation_kind : kind Consensus_operation_type.t) (expected_content : kind expected_consensus_content) : unit tzresult = let expected_level = expected_content.level.level in let provided_level = content.level in @@ -2668,7 +2686,7 @@ let check_consensus_content (type kind) (apply_mode : apply_mode) a preendorsement pointing to the direct proposal. This preendorsement wouldn't be able to propagate for a subsequent proposal using it as a locked_round evidence. *) let validate_consensus_contents (type kind) ctxt chain_id - (operation_kind : kind consensus_operation_type) + (operation_kind : kind Consensus_operation_type.t) (operation : kind operation) (apply_mode : apply_mode) (content : consensus_content) : (context * public_key_hash * int) tzresult Lwt.t = @@ -2735,13 +2753,15 @@ let check_denunciation_age ctxt kind given_level = (Outdated_denunciation {kind; level = given_level; last_cycle = last_slashable_cycle}) +type mistake = Double_baking | Double_endorsing + let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = let (already_slashed, punish) = match mistake with - | `Double_baking -> + | Double_baking -> ( Delegate.already_slashed_for_double_baking, Delegate.punish_double_baking ) - | `Double_endorsing -> + | Double_endorsing -> ( Delegate.already_slashed_for_double_endorsing, Delegate.punish_double_endorsing ) in @@ -2752,8 +2772,8 @@ let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = | Ok reward -> Token.transfer ctxt - `Double_signing_evidence_rewards - (`Contract (Contract.implicit_contract payload_producer)) + (Source_infinite Double_signing_evidence_rewards) + (Sink_container (Contract (Contract.implicit_contract payload_producer))) reward | Error _ -> (* reward is Tez.zero *) return (ctxt, [])) >|=? fun (ctxt, reward_balance_updates) -> @@ -2769,13 +2789,15 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id Lwt.t = let mk_result (balance_updates : Receipt.balance_updates) : kind Kind.double_consensus_operation_evidence contents_result = - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement _) -> Double_preendorsement_evidence_result balance_updates | Single (Endorsement _) -> Double_endorsement_evidence_result balance_updates in - match (op1.protocol_data.contents, op2.protocol_data.contents) with + match[@coq_match_with_default] + (op1.protocol_data.contents, op2.protocol_data.contents) + with | (Single (Preendorsement e1), Single (Preendorsement e2)) | (Single (Endorsement e1), Single (Endorsement e2)) -> let kind = if preendorsement then Preendorsement else Endorsement in @@ -2811,7 +2833,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id ctxt delegate level - `Double_endorsing + Double_endorsing mk_result ~payload_producer @@ -2854,7 +2876,7 @@ let punish_double_baking ctxt chain_id bh1 bh2 ~payload_producer = ctxt delegate level - `Double_baking + Double_baking ~payload_producer (fun balance_updates -> Double_baking_evidence_result balance_updates) @@ -2875,7 +2897,7 @@ let is_parent_endorsement ctxt ~proposal_level ~grand_parent_round let validate_grand_parent_endorsement ctxt chain_id (op : Kind.endorsement operation) = - match op.protocol_data.contents with + match[@coq_match_with_default] op.protocol_data.contents with | Single (Endorsement e) -> let level = Level.from_raw ctxt e.level in Stake_distribution.slot_owner ctxt level e.slot @@ -2966,7 +2988,11 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode Nonce.reveal ctxt level nonce >>=? fun ctxt -> let tip = Constants.seed_nonce_revelation_tip ctxt in let contract = Contract.implicit_contract payload_producer in - Token.transfer ctxt `Revelation_rewards (`Contract contract) tip + Token.transfer + ctxt + (Source_infinite Revelation_rewards) + (Sink_container (Contract contract)) + tip >|=? fun (ctxt, balance_updates) -> (ctxt, Single_result (Seed_nonce_revelation_result balance_updates)) | Single (Double_preendorsement_evidence {op1; op2}) -> @@ -2991,12 +3017,16 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode let blinded_pkh = Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in - let src = `Collected_commitments blinded_pkh in + let src = Token.Collected_commitments blinded_pkh in Token.allocated ctxt src >>=? fun (ctxt, src_exists) -> fail_unless src_exists (Invalid_activation {pkh}) >>=? fun () -> let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in Token.balance ctxt src >>=? fun (ctxt, amount) -> - Token.transfer ctxt src (`Contract contract) amount + Token.transfer + ctxt + (Source_container src) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, bupds) -> return (ctxt, Single_result (Activate_account_result bupds)) | Single (Proposals {source; period; proposals}) -> @@ -3126,8 +3156,8 @@ let apply_liquidity_baking_subsidy ctxt ~toggle_vote = Token.transfer ~origin:Subsidy ctxt - `Liquidity_baking_subsidies - (`Contract liquidity_baking_cpmm_contract) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract liquidity_baking_cpmm_contract)) liquidity_baking_subsidy >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt liquidity_baking_cpmm_contract diff --git a/src/proto_013_PtJakart/lib_protocol/apply_results.ml b/src/proto_013_PtJakart/lib_protocol/apply_results.ml index 065e5d6c4f0c0..c60339933ab17 100644 --- a/src/proto_013_PtJakart/lib_protocol/apply_results.ml +++ b/src/proto_013_PtJakart/lib_protocol/apply_results.ml @@ -333,7 +333,7 @@ module Manager_result = struct in MCase {op_case; encoding; kind; select; proj; inj; t} - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make ~op_case:Operation.Encoding.Manager_operations.reveal_case ~encoding: @@ -345,14 +345,14 @@ module Manager_result = struct | Successful_manager_result (Reveal_result _ as op) -> Some op | _ -> None) ~kind:Kind.Reveal_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Reveal_result {consumed_gas} -> (Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (consumed_gas, consumed_milligas) -> assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; Reveal_result {consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = + let transaction_contract_variant_cases = union [ case @@ -451,7 +451,7 @@ module Manager_result = struct }); ] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make ~op_case:Operation.Encoding.Manager_operations.transaction_case ~encoding:transaction_contract_variant_cases @@ -459,10 +459,10 @@ module Manager_result = struct | Successful_manager_result (Transaction_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function Transaction_result x -> x) + ~proj:(function[@coq_match_with_default] Transaction_result x -> x) ~inj:(fun x -> Transaction_result x) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make ~op_case:Operation.Encoding.Manager_operations.origination_case ~encoding: @@ -477,7 +477,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Origination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Origination_result { lazy_storage_diff; @@ -514,7 +514,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make ~op_case: Operation.Encoding.Manager_operations.register_global_constant_case @@ -529,7 +529,7 @@ module Manager_result = struct | Successful_manager_result (Register_global_constant_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Register_global_constant_result {balance_updates; consumed_gas; size_of_constant; global_address} -> ( balance_updates, @@ -585,14 +585,14 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Set_deposits_limit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Set_deposits_limit_result {consumed_gas} -> (Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (consumed_gas, consumed_milligas) -> assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; Set_deposits_limit_result {consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_origination_case ~encoding: @@ -607,7 +607,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_origination_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_origination_result {balance_updates; consumed_gas; originated_tx_rollup} -> ( balance_updates, @@ -627,7 +627,7 @@ module Manager_result = struct originated_tx_rollup; }) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_submit_batch_case ~encoding: @@ -642,7 +642,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_submit_batch_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_submit_batch_result {balance_updates; consumed_gas; paid_storage_size_diff} -> ( balance_updates, @@ -662,7 +662,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_commit_case ~encoding: @@ -675,7 +675,7 @@ module Manager_result = struct | Successful_manager_result (Tx_rollup_commit_result _ as op) -> Some op | _ -> None) ~kind:Kind.Tx_rollup_commit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_commit_result {balance_updates; consumed_gas} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) -> @@ -683,7 +683,7 @@ module Manager_result = struct Tx_rollup_commit_result {balance_updates; consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_return_bond_case ~encoding: @@ -697,7 +697,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_return_bond_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_return_bond_result {balance_updates; consumed_gas} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) -> @@ -705,7 +705,7 @@ module Manager_result = struct Tx_rollup_return_bond_result {balance_updates; consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_finalize_commitment_case @@ -722,7 +722,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_finalize_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas, level)) @@ -731,7 +731,7 @@ module Manager_result = struct Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas = consumed_milligas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_remove_commitment_case @@ -748,7 +748,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_remove_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_remove_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas, level)) @@ -757,7 +757,7 @@ module Manager_result = struct Tx_rollup_remove_commitment_result {balance_updates; consumed_gas = consumed_milligas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_rejection_case ~encoding: @@ -771,7 +771,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_rejection_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_rejection_result {balance_updates; consumed_gas} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) -> @@ -779,7 +779,7 @@ module Manager_result = struct Tx_rollup_rejection_result {balance_updates; consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_dispatch_tickets_case @@ -796,7 +796,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_dispatch_tickets_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_dispatch_tickets_result {balance_updates; consumed_gas; paid_storage_size_diff} -> ( balance_updates, @@ -816,7 +816,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make ~op_case:Operation.Encoding.Manager_operations.transfer_ticket_case ~encoding: @@ -830,7 +830,7 @@ module Manager_result = struct | Successful_manager_result (Transfer_ticket_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transfer_ticket_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Transfer_ticket_result {balance_updates; consumed_gas; paid_storage_size_diff} -> ( balance_updates, @@ -850,7 +850,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make ~op_case:Operation.Encoding.Manager_operations.sc_rollup_originate_case ~encoding: @@ -864,7 +864,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_originate_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_originate_result {balance_updates; address; consumed_gas; size} -> ( balance_updates, @@ -891,7 +891,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_add_messages_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_add_messages_result {consumed_gas; inbox_after} -> (Gas.Arith.ceil consumed_gas, consumed_gas, inbox_after)) ~kind:Kind.Sc_rollup_add_messages_manager_kind @@ -910,7 +910,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Sc_rollup_cement_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_cement_result {consumed_gas} -> (Gas.Arith.ceil consumed_gas, consumed_gas)) ~kind:Kind.Sc_rollup_cement_manager_kind @@ -930,7 +930,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_publish_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_publish_result {consumed_gas; staked_hash} -> (Gas.Arith.ceil consumed_gas, consumed_gas, staked_hash)) ~kind:Kind.Sc_rollup_publish_manager_kind @@ -961,7 +961,7 @@ module Internal_result = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = MCase { tag = Operation.Encoding.Manager_operations.transaction_tag; @@ -984,7 +984,7 @@ module Internal_result = struct select = (function Manager (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -1004,7 +1004,7 @@ module Internal_result = struct Transaction {amount; destination; parameters; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = MCase { tag = Operation.Encoding.Manager_operations.origination_tag; @@ -1023,14 +1023,14 @@ module Internal_result = struct select = (function Manager (Origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = (fun (credit, delegate, script) -> Origination {credit; delegate; script}); } - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = MCase { tag = Operation.Encoding.Manager_operations.delegation_tag; @@ -1044,7 +1044,7 @@ module Internal_result = struct | _ -> None); select = (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); + proj = (function[@coq_match_with_default] Delegation key -> key); inj = (fun key -> Delegation key); } @@ -1057,13 +1057,16 @@ module Internal_result = struct (fun ((), x) -> inj x) let encoding = - let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Manager (inj x)) + let make m_case = + match[@coq_grab_existentials] m_case with + | MCase {tag; name; encoding; iselect = _; select; proj; inj} -> + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Manager (inj x)) in union ~tag_size:`Uint8 @@ -1085,27 +1088,30 @@ let internal_manager_operation_result_encoding : packed_internal_manager_operation_result Data_encoding.t = let make (type kind) (Manager_result.MCase res_case : kind Manager_result.case) - (Internal_result.MCase ires_case : kind Internal_result.case) = + (ires_case : kind Internal_result.case) = let (Operation.Encoding.Manager_operations.MCase op_case) = res_case.op_case in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs - (obj3 - (req "kind" (constant op_case.name)) - (req "source" Contract.encoding) - (req "nonce" uint16)) - (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) - (fun op -> - match ires_case.iselect op with - | Some (op, res) -> - Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) - | None -> None) - (fun (((), source, nonce), (op, res)) -> - let op = {source; operation = ires_case.inj op; nonce} in - Internal_manager_operation_result (op, res)) + match[@coq_grab_existentials] ires_case with + | Internal_result.MCase ires_case -> + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj3 + (req "kind" (constant op_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) + (fun op -> + match ires_case.iselect op with + | Some (op, res) -> + Some + (((), op.source, op.nonce), (ires_case.proj op.operation, res)) + | None -> None) + (fun (((), source, nonce), (op, res)) -> + let op = {source; operation = ires_case.inj op; nonce} in + Internal_manager_operation_result (op, res)) in def "apply_results.alpha.operation_result" @@ union @@ -1117,20 +1123,23 @@ let internal_manager_operation_result_encoding : let successful_manager_operation_result_encoding : packed_successful_manager_operation_result Data_encoding.t = - let make (type kind) - (Manager_result.MCase res_case : kind Manager_result.case) = - let (Operation.Encoding.Manager_operations.MCase op_case) = - res_case.op_case - in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs (obj1 (req "kind" (constant op_case.name))) res_case.encoding) - (fun res -> - match res_case.select res with - | Some res -> Some ((), res_case.proj res) - | None -> None) - (fun ((), res) -> Successful_manager_result (res_case.inj res)) + let make (type kind) (mcase : kind Manager_result.case) = + match[@coq_grab_existentials] mcase with + | Manager_result.MCase res_case -> + let (Operation.Encoding.Manager_operations.MCase op_case) = + res_case.op_case + in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj1 (req "kind" (constant op_case.name))) + res_case.encoding) + (fun res -> + match res_case.select res with + | Some res -> Some ((), res_case.proj res) + | None -> None) + (fun ((), res) -> Successful_manager_result (res_case.inj res)) in def "operation.alpha.successful_manager_operation_result" @@ union @@ -1283,7 +1292,7 @@ module Encoding = struct (fun x -> match proj x with None -> None | Some x -> Some ((), x)) (fun ((), x) -> inj x) - let[@coq_axiom_with_reason "gadt"] preendorsement_case = + let preendorsement_case = Case { op_case = Operation.Encoding.preendorsement_case; @@ -1301,7 +1310,7 @@ module Encoding = struct | Contents_and_result ((Preendorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Preendorsement_result {balance_updates; delegate; preendorsement_power} -> (balance_updates, delegate, preendorsement_power)); @@ -1311,7 +1320,7 @@ module Encoding = struct {balance_updates; delegate; preendorsement_power}); } - let[@coq_axiom_with_reason "gadt"] endorsement_case = + let endorsement_case = Case { op_case = Operation.Encoding.endorsement_case; @@ -1328,7 +1337,7 @@ module Encoding = struct | Contents_and_result ((Endorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Endorsement_result {balance_updates; delegate; endorsement_power} -> (balance_updates, delegate, endorsement_power)); inj = @@ -1336,7 +1345,7 @@ module Encoding = struct Endorsement_result {balance_updates; delegate; endorsement_power}); } - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { op_case = Operation.Encoding.seed_nonce_revelation_case; @@ -1351,11 +1360,13 @@ module Encoding = struct | Contents_and_result ((Seed_nonce_revelation _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Seed_nonce_revelation_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation_result bus) -> + bus); inj = (fun bus -> Seed_nonce_revelation_result bus); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case = + let double_endorsement_evidence_case = Case { op_case = Operation.Encoding.double_endorsement_evidence_case; @@ -1371,11 +1382,14 @@ module Encoding = struct | Contents_and_result ((Double_endorsement_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_endorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_endorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case = + let double_preendorsement_evidence_case = Case { op_case = Operation.Encoding.double_preendorsement_evidence_case; @@ -1392,11 +1406,14 @@ module Encoding = struct -> Some (op, res) | _ -> None); - proj = (fun (Double_preendorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_preendorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { op_case = Operation.Encoding.double_baking_evidence_case; @@ -1411,11 +1428,13 @@ module Encoding = struct | Contents_and_result ((Double_baking_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_baking_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence_result bus) -> + bus); inj = (fun bus -> Double_baking_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { op_case = Operation.Encoding.activate_account_case; @@ -1430,11 +1449,12 @@ module Encoding = struct | Contents_and_result ((Activate_account _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Activate_account_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Activate_account_result bus) -> bus); inj = (fun bus -> Activate_account_result bus); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { op_case = Operation.Encoding.proposals_case; @@ -1446,11 +1466,11 @@ module Encoding = struct (function | Contents_and_result ((Proposals _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Proposals_result -> ()); + proj = (fun [@coq_match_with_default] Proposals_result -> ()); inj = (fun () -> Proposals_result); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { op_case = Operation.Encoding.ballot_case; @@ -1462,11 +1482,11 @@ module Encoding = struct (function | Contents_and_result ((Ballot _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Ballot_result -> ()); + proj = (fun [@coq_match_with_default] Ballot_result -> ()); inj = (fun () -> Ballot_result); } - let[@coq_axiom_with_reason "gadt"] make_manager_case (type kind) + let make_manager_case (type kind) (Operation.Encoding.Case op_case : kind Kind.manager Operation.Encoding.case) (Manager_result.MCase res_case : kind Manager_result.case) mselect = @@ -1530,12 +1550,12 @@ module Encoding = struct | Contents_result Proposals_result -> None); mselect; proj = - (fun (Manager_operation_result - { - balance_updates = bus; - operation_result = r; - internal_operation_results = rs; - }) -> + (fun [@coq_match_with_default] (Manager_operation_result + { + balance_updates = bus; + operation_result = r; + internal_operation_results = rs; + }) -> (bus, r, rs)); inj = (fun (bus, r, rs) -> @@ -1547,7 +1567,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make_manager_case Operation.Encoding.reveal_case Manager_result.reveal_case @@ -1557,7 +1577,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make_manager_case Operation.Encoding.transaction_case Manager_result.transaction_case @@ -1567,7 +1587,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make_manager_case Operation.Encoding.origination_case Manager_result.origination_case @@ -1577,7 +1597,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = make_manager_case Operation.Encoding.delegation_case Manager_result.delegation_case @@ -1587,7 +1607,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make_manager_case Operation.Encoding.register_global_constant_case Manager_result.register_global_constant_case @@ -1599,7 +1619,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = make_manager_case Operation.Encoding.set_deposits_limit_case Manager_result.set_deposits_limit_case @@ -1610,7 +1630,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make_manager_case Operation.Encoding.tx_rollup_origination_case Manager_result.tx_rollup_origination_case @@ -1621,7 +1641,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make_manager_case Operation.Encoding.tx_rollup_submit_batch_case Manager_result.tx_rollup_submit_batch_case @@ -1632,7 +1652,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make_manager_case Operation.Encoding.tx_rollup_commit_case Manager_result.tx_rollup_commit_case @@ -1643,7 +1663,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make_manager_case Operation.Encoding.tx_rollup_return_bond_case Manager_result.tx_rollup_return_bond_case @@ -1654,7 +1674,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make_manager_case Operation.Encoding.tx_rollup_finalize_commitment_case Manager_result.tx_rollup_finalize_commitment_case @@ -1666,7 +1686,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make_manager_case Operation.Encoding.tx_rollup_remove_commitment_case Manager_result.tx_rollup_remove_commitment_case @@ -1678,7 +1698,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make_manager_case Operation.Encoding.tx_rollup_rejection_case Manager_result.tx_rollup_rejection_case @@ -1689,7 +1709,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make_manager_case Operation.Encoding.tx_rollup_dispatch_tickets_case Manager_result.tx_rollup_dispatch_tickets_case @@ -1701,7 +1721,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make_manager_case Operation.Encoding.transfer_ticket_case Manager_result.transfer_ticket_case @@ -1712,7 +1732,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make_manager_case Operation.Encoding.sc_rollup_originate_case Manager_result.sc_rollup_originate_case @@ -1723,7 +1743,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = make_manager_case Operation.Encoding.sc_rollup_add_messages_case Manager_result.sc_rollup_add_messages_case @@ -1734,7 +1754,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = make_manager_case Operation.Encoding.sc_rollup_cement_case Manager_result.sc_rollup_cement_case @@ -1745,7 +1765,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = make_manager_case Operation.Encoding.sc_rollup_publish_case Manager_result.sc_rollup_publish_case @@ -1759,8 +1779,9 @@ end let contents_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; _}; encoding; @@ -1768,10 +1789,12 @@ let contents_result_encoding = select; proj; inj; - }) = - let proj x = match select x with None -> None | Some x -> Some (proj x) in - let inj x = Contents_result (inj x) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj x = + match select x with None -> None | Some x -> Some (proj x) + in + let inj x = Contents_result (inj x) in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.contents_result" @@ union @@ -1808,8 +1831,9 @@ let contents_result_encoding = let contents_and_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _}; mselect; @@ -1817,15 +1841,17 @@ let contents_and_result_encoding = proj = meta_proj; inj = meta_inj; _; - }) = - let proj c = - match mselect c with - | Some (op, res) -> Some (proj op, meta_proj res) - | _ -> None - in - let inj (op, res) = Contents_and_result (inj op, meta_inj res) in - let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj c = + match mselect c with + | Some (op, res) -> Some (proj op, meta_proj res) + | _ -> None + in + let inj (op, res) = Contents_and_result (inj op, meta_inj res) in + let encoding = + merge_objs encoding (obj1 (req "metadata" meta_encoding)) + in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.operation_contents_and_result" @@ union @@ -1872,27 +1898,34 @@ type packed_contents_result_list = 'kind contents_result_list -> packed_contents_result_list +let rec contents_result_list_to_list : type kind. kind contents_result_list -> _ + = function + | Single_result o -> [Contents_result o] + | Cons_result (o, os) -> Contents_result o :: contents_result_list_to_list os + +let packed_contents_result_list_to_list = function + | Contents_result_list l -> contents_result_list_to_list l + +let rec packed_contents_result_list_of_list = function + | [] -> Error "cannot decode empty operation result" + | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) + | Contents_result o :: os -> ( + packed_contents_result_list_of_list os + >>? fun (Contents_result_list os) -> + match (o, os) with + | (Manager_operation_result _, Single_result (Manager_operation_result _)) + -> + Ok (Contents_result_list (Cons_result (o, os))) + | (Manager_operation_result _, Cons_result _) -> + Ok (Contents_result_list (Cons_result (o, os))) + | _ -> Error "cannot decode ill-formed operation result") + let contents_result_list_encoding = - let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - in - let rec of_list = function - | [] -> Error "cannot decode empty operation result" - | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) - | Contents_result o :: os -> ( - of_list os >>? fun (Contents_result_list os) -> - match (o, os) with - | ( Manager_operation_result _, - Single_result (Manager_operation_result _) ) -> - Ok (Contents_result_list (Cons_result (o, os))) - | (Manager_operation_result _, Cons_result _) -> - Ok (Contents_result_list (Cons_result (o, os))) - | _ -> Error "cannot decode ill-formed operation result") - in def "operation.alpha.contents_list_result" - @@ conv_with_guard to_list of_list (list contents_result_encoding) + @@ conv_with_guard + packed_contents_result_list_to_list + packed_contents_result_list_of_list + (list contents_result_encoding) type 'kind contents_and_result_list = | Single_and_result : @@ -1909,27 +1942,34 @@ type packed_contents_and_result_list = 'kind contents_and_result_list -> packed_contents_and_result_list +let rec contents_and_result_list_to_list : + type kind. kind contents_and_result_list -> _ = function + | Single_and_result (op, res) -> [Contents_and_result (op, res)] + | Cons_and_result (op, res, rest) -> + Contents_and_result (op, res) :: contents_and_result_list_to_list rest + +let packed_contents_and_result_list_to_list = function + | Contents_and_result_list l -> contents_and_result_list_to_list l + +let rec packed_contents_and_result_list_of_list = function + | [] -> Error "cannot decode empty combined operation result" + | [Contents_and_result (op, res)] -> + Ok (Contents_and_result_list (Single_and_result (op, res))) + | Contents_and_result (op, res) :: rest -> ( + packed_contents_and_result_list_of_list rest + >>? fun (Contents_and_result_list rest) -> + match (op, rest) with + | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | (Manager_operation _, Cons_and_result (_, _, _)) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | _ -> Error "cannot decode ill-formed combined operation result") + let contents_and_result_list_encoding = - let rec to_list = function - | Contents_and_result_list (Single_and_result (op, res)) -> - [Contents_and_result (op, res)] - | Contents_and_result_list (Cons_and_result (op, res, rest)) -> - Contents_and_result (op, res) :: to_list (Contents_and_result_list rest) - in - let rec of_list = function - | [] -> Error "cannot decode empty combined operation result" - | [Contents_and_result (op, res)] -> - Ok (Contents_and_result_list (Single_and_result (op, res))) - | Contents_and_result (op, res) :: rest -> ( - of_list rest >>? fun (Contents_and_result_list rest) -> - match (op, rest) with - | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | (Manager_operation _, Cons_and_result (_, _, _)) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | _ -> Error "cannot decode ill-formed combined operation result") - in - conv_with_guard to_list of_list (Variable.list contents_and_result_encoding) + conv_with_guard + packed_contents_and_result_list_to_list + packed_contents_and_result_list_of_list + (Variable.list contents_and_result_encoding) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -2504,13 +2544,13 @@ let rec kind_equal_list : | Some Eq -> Some Eq)) | _ -> None -let[@coq_axiom_with_reason "gadt"] rec pack_contents_list : +let rec pack_contents_list : type kind. kind contents_list -> kind contents_result_list -> kind contents_and_result_list = fun contents res -> - match (contents, res) with + match[@coq_match_with_default] (contents, res) with | (Single op, Single_result res) -> Single_and_result (op, res) | (Cons (op, ops), Cons_result (res, ress)) -> Cons_and_result (op, res, pack_contents_list ops ress) @@ -2544,11 +2584,6 @@ let rec unpack_contents_list : let (ops, ress) = unpack_contents_list rest in (Cons (op, ops), Cons_result (res, ress)) -let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - let operation_data_and_metadata_encoding = def "operation.alpha.operation_with_metadata" @@ union diff --git a/src/proto_013_PtJakart/lib_protocol/apply_results.mli b/src/proto_013_PtJakart/lib_protocol/apply_results.mli index cea567bab6349..8b4b0e87f3904 100644 --- a/src/proto_013_PtJakart/lib_protocol/apply_results.mli +++ b/src/proto_013_PtJakart/lib_protocol/apply_results.mli @@ -329,7 +329,8 @@ val unpack_contents_list : 'kind contents_and_result_list -> 'kind contents_list * 'kind contents_result_list -val to_list : packed_contents_result_list -> packed_contents_result list +val packed_contents_result_list_to_list : + packed_contents_result_list -> packed_contents_result list type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/proto_013_PtJakart/lib_protocol/baking.ml b/src/proto_013_PtJakart/lib_protocol/baking.ml index eb10613fe00df..b3fd2f26f4b89 100644 --- a/src/proto_013_PtJakart/lib_protocol/baking.ml +++ b/src/proto_013_PtJakart/lib_protocol/baking.ml @@ -70,7 +70,7 @@ let bonus_baking_reward ctxt ~endorsing_power = Tez.(baking_reward_bonus_per_slot *? Int64.of_int extra_endorsing_power) let baking_rights c level = - let rec f c round = + let[@coq_struct "round"] rec f c round = Stake_distribution.baking_rights_owner c level ~round >>=? fun (c, _slot, (delegate, _)) -> return (LCons (delegate, fun () -> f c (Round.succ round))) diff --git a/src/proto_013_PtJakart/lib_protocol/bootstrap_storage.ml b/src/proto_013_PtJakart/lib_protocol/bootstrap_storage.ml index 3636d5f1793e7..1ca42e9246dbe 100644 --- a/src/proto_013_PtJakart/lib_protocol/bootstrap_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/bootstrap_storage.ml @@ -30,8 +30,8 @@ let init_account (ctxt, balance_updates) Token.transfer ~origin:Protocol_migration ctxt - `Bootstrap - (`Contract contract) + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) amount >>=? fun (ctxt, new_balance_updates) -> (match public_key with @@ -60,7 +60,12 @@ let init_contract ~typecheck (ctxt, balance_updates) | Some delegate -> Delegate_storage.init ctxt contract delegate) >>=? fun ctxt -> let origin = Receipt_repr.Protocol_migration in - Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount + Token.transfer + ~origin + ctxt + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) + amount >|=? fun (ctxt, new_balance_updates) -> (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_013_PtJakart/lib_protocol/cache_repr.ml b/src/proto_013_PtJakart/lib_protocol/cache_repr.ml index 1fb43b8739c3e..2359480d4dc04 100644 --- a/src/proto_013_PtJakart/lib_protocol/cache_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/cache_repr.ml @@ -264,15 +264,17 @@ let register_exn (type cvalue) >>?= fun ctxt -> Admin.find ctxt (mk ~id) >>= function | None -> return None - | Some (K v) -> return (Some v) - | _ -> - (* This execution path is impossible because all the keys of - C's namespace (which is unique to C) are constructed with - [K]. This [assert false] could have been pushed into the - environment in exchange for extra complexity. The - argument that justifies this [assert false] seems - simple enough to keep the current design though. *) - assert false + | Some value -> ( + match value with + | K v -> return (Some v) + | _ -> + (* This execution path is impossible because all the keys of + C's namespace (which is unique to C) are constructed with + [K]. This [assert false] could have been pushed into the + environment in exchange for extra complexity. The + argument that justifies this [assert false] seems + simple enough to keep the current design though. *) + assert false) let list_identifiers ctxt = Admin.list_keys ctxt ~cache_index:C.cache_index |> function diff --git a/src/proto_013_PtJakart/lib_protocol/carbonated_map.ml b/src/proto_013_PtJakart/lib_protocol/carbonated_map.ml index ceda9cd2c8537..0a50804c93c37 100644 --- a/src/proto_013_PtJakart/lib_protocol/carbonated_map.ml +++ b/src/proto_013_PtJakart/lib_protocol/carbonated_map.ml @@ -80,7 +80,7 @@ module type COMPARABLE = sig val compare_cost : t -> Gas.cost end -module Make (C : COMPARABLE) = struct +module Make (C : COMPARABLE) : S with type key := C.t = struct module M = Map.Make (C) type 'a t = {map : 'a M.t; size : int} diff --git a/src/proto_013_PtJakart/lib_protocol/contract_services.ml b/src/proto_013_PtJakart/lib_protocol/contract_services.ml index f60675624690c..4b5a9150f649c 100644 --- a/src/proto_013_PtJakart/lib_protocol/contract_services.ml +++ b/src/proto_013_PtJakart/lib_protocol/contract_services.ml @@ -285,7 +285,7 @@ module S = struct end end -let[@coq_axiom_with_reason "gadt"] register () = +let register () = let open Services_registration in register0 ~chunked:true S.list (fun ctxt () () -> Contract.list ctxt >|= ok) ; let register_field ~chunked s f = @@ -314,7 +314,7 @@ let[@coq_axiom_with_reason "gadt"] register () = | None -> return_none | Some (_, value_type) -> ( parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type) - >>?= fun (Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Ex_ty value_type, ctxt) -> Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) -> match value with | None -> return_none @@ -326,7 +326,7 @@ let[@coq_axiom_with_reason "gadt"] register () = value_type (Micheline.root value) >>=? fun (value, ctxt) -> - unparse_data ctxt Readable value_type value + unparse_data ctxt Readable value_type (value [@coq_type_annotation]) >|=? fun (value, _ctxt) -> Some (Micheline.strip_locations value)) in let do_big_map_get_all ?offset ?length ctxt id = @@ -337,7 +337,7 @@ let[@coq_axiom_with_reason "gadt"] register () = | None -> raise Not_found | Some (_, value_type) -> parse_big_map_value_ty ctxt ~legacy:true (Micheline.root value_type) - >>?= fun (Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Ex_ty value_type, ctxt) -> Big_map.list_values ?offset ?length ctxt id >>=? fun (ctxt, values) -> List.fold_left_s (fun acc value -> @@ -349,7 +349,7 @@ let[@coq_axiom_with_reason "gadt"] register () = value_type (Micheline.root value) >>=? fun (value, ctxt) -> - unparse_data ctxt Readable value_type value + unparse_data ctxt Readable value_type (value [@coq_type_annotation]) >|=? fun (value, ctxt) -> (ctxt, Micheline.strip_locations value :: rev_values)) (Ok (ctxt, [])) @@ -408,22 +408,25 @@ let[@coq_axiom_with_reason "gadt"] register () = parse_toplevel ctxt ~legacy expr >>=? fun ({arg_type; _}, ctxt) -> Lwt.return ( parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type - >>? fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) - -> - Gas_monad.run ctxt - @@ Script_ir_translator.find_entrypoint - ~error_details:Informative - arg_type - entrypoints - entrypoint - >>? fun (r, ctxt) -> - r |> function - | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> - if normalize_types then - unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _ctxt) -> - Some (Micheline.strip_locations ty_node) - else ok (Some (Micheline.strip_locations original_type_expr)) - | Error _ -> Result.return_none )) ; + >>? fun arg -> + match[@coq_match_gadt_with_result] arg with + | (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _) + -> ( + Gas_monad.run ctxt + @@ Script_ir_translator.find_entrypoint + ~error_details:Informative + arg_type + entrypoints + entrypoint + >>? fun (r, ctxt) -> + r |> function + | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> + if normalize_types then + unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _ctxt) -> + Some (Micheline.strip_locations ty_node) + else + ok (Some (Micheline.strip_locations original_type_expr)) + | Error _ -> Result.return_none) )) ; opt_register1 ~chunked:true S.list_entrypoints diff --git a/src/proto_013_PtJakart/lib_protocol/contract_storage.ml b/src/proto_013_PtJakart/lib_protocol/contract_storage.ml index 71dcf5dbf3062..0774c4426d379 100644 --- a/src/proto_013_PtJakart/lib_protocol/contract_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/contract_storage.ml @@ -356,48 +356,56 @@ module Legacy_big_map_diff = struct let of_lazy_storage_diff diffs = List.fold_left - (fun legacy_diffs (Lazy_storage_diff.Item (kind, id, diff)) -> - let diffs = - match kind with - | Lazy_storage_kind.Big_map -> ( - let id = - Lazy_storage_kind.Big_map.Id - .to_legacy_USE_ONLY_IN_Legacy_big_map_diff - id - in - match diff with - | Remove -> [Clear id] - | Update {init; updates} -> ( - let updates = - List.rev_map - (fun {Lazy_storage_kind.Big_map.key; key_hash; value} -> - Update - { - big_map = id; - diff_key = key; - diff_key_hash = key_hash; - diff_value = value; - }) - updates + (fun legacy_diffs arg -> + match[@coq_match_gadt_with_result] arg with + | Lazy_storage_diff.Item (kind, id, diff) -> + let diffs = + match[@coq_match_gadt] kind with + | Lazy_storage_kind.Big_map -> ( + let id = + Lazy_storage_kind.Big_map.Id + .to_legacy_USE_ONLY_IN_Legacy_big_map_diff + ((id [@coq_cast]) : Storage.Big_map.id) in - match init with - | Existing -> updates - | Copy {src} -> - let src = - Lazy_storage_kind.Big_map.Id - .to_legacy_USE_ONLY_IN_Legacy_big_map_diff - src + match[@coq_match_gadt] diff with + | Remove -> [Clear id] + | Update {init; updates} -> ( + let updates = + List.rev_map + (fun {Lazy_storage_kind.Big_map.key; key_hash; value} -> + Update + { + big_map = id; + diff_key = key; + diff_key_hash = key_hash; + diff_value = value; + }) + ((updates [@coq_cast]) + : Lazy_storage_kind.Big_map.update list) in - Copy {src; dst = id} :: updates - | Alloc {key_type; value_type} -> - Alloc {big_map = id; key_type; value_type} :: updates)) - | _ -> (* Not a Big_map *) [] - in - diffs :: legacy_diffs) + match[@coq_match_gadt] init with + | Existing -> updates + | Copy {src} -> + let src = + Lazy_storage_kind.Big_map.Id + .to_legacy_USE_ONLY_IN_Legacy_big_map_diff + ((src [@coq_cast]) : Storage.Big_map.id) + in + Copy {src; dst = id} :: updates + | Alloc r -> ( + match + ((r [@coq_cast]) : Lazy_storage_kind.Big_map.alloc) + with + | {key_type; value_type} -> + (* : Lazy_storage_kind.Big_map.alloc *) + Alloc {big_map = id; key_type; value_type} + :: updates))) + | _ -> (* Not a Big_map *) [] + in + diffs :: legacy_diffs) [] diffs |> List.rev |> List.flatten - [@@coq_axiom_with_reason "gadt"] end let update_script_lazy_storage c = function diff --git a/src/proto_013_PtJakart/lib_protocol/delegate_storage.ml b/src/proto_013_PtJakart/lib_protocol/delegate_storage.ml index 37110cf1f2d2b..80d2c8cee6e9f 100644 --- a/src/proto_013_PtJakart/lib_protocol/delegate_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/delegate_storage.ml @@ -362,8 +362,8 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Sufficient participation: we pay the rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Contract delegate_contract) + (Source_infinite Endorsing_rewards) + (Sink_container (Contract delegate_contract)) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates) @@ -371,9 +371,10 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Insufficient participation or unrevealed nonce: no rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Lost_endorsing_rewards - (delegate, not sufficient_participation, not has_revealed_nonces)) + (Source_infinite Endorsing_rewards) + (Sink_infinite + (Lost_endorsing_rewards + (delegate, not sufficient_participation, not has_revealed_nonces))) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates)) @@ -477,8 +478,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) to_reimburse >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else if Tez_repr.(current_amount < maximum_stake_to_be_deposited) then @@ -498,8 +499,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Delegate_balance delegate) - (`Frozen_deposits delegate) + (Source_container (Delegate_balance delegate)) + (Sink_container (Frozen_deposits delegate)) to_freeze >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -525,8 +526,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) frozen_deposits.current_amount >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -749,7 +750,7 @@ module Random = struct the sequence and try again). *) Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop (bytes, n) = + let[@coq_struct "function_parameter"] rec loop (bytes, n) = let consumed_bytes = 8 in let state_size = Bytes.length bytes in if Compare.Int.(n > state_size - consumed_bytes) then @@ -832,8 +833,8 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -863,8 +864,8 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -943,15 +944,22 @@ let record_baking_activity_and_pay_rewards_and_fees ctxt ~payload_producer >>=? fun ctxt -> let pay_payload_producer ctxt delegate = let contract = Contract_repr.implicit_contract delegate in - Token.balance ctxt `Block_fees >>=? fun (ctxt, block_fees) -> + Token.balance ctxt Block_fees >>=? fun (ctxt, block_fees) -> Token.transfer_n ctxt - [(`Block_fees, block_fees); (`Baking_rewards, baking_reward)] - (`Contract contract) + [ + (Source_container Block_fees, block_fees); + (Source_infinite Baking_rewards, baking_reward); + ] + (Sink_container (Contract contract)) in let pay_block_producer ctxt delegate bonus = let contract = Contract_repr.implicit_contract delegate in - Token.transfer ctxt `Baking_bonuses (`Contract contract) bonus + Token.transfer + ctxt + (Source_infinite Baking_bonuses) + (Sink_container (Contract contract)) + bonus in pay_payload_producer ctxt payload_producer >>=? fun (ctxt, balance_updates_payload_producer) -> diff --git a/src/proto_013_PtJakart/lib_protocol/dependent_bool.ml b/src/proto_013_PtJakart/lib_protocol/dependent_bool.ml index 8fb3c49ec11a7..5ae4a13404e10 100644 --- a/src/proto_013_PtJakart/lib_protocol/dependent_bool.ml +++ b/src/proto_013_PtJakart/lib_protocol/dependent_bool.ml @@ -36,7 +36,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] let dand : type a b. a dbool -> b dbool -> (a, b) ex_dand = fun a b -> @@ -57,7 +57,7 @@ type (_, _) eq = Eq : ('a, 'a) eq let merge_dand : type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq = fun w1 w2 -> - match (w1, w2) with + match[@coq_match_with_default] (w1, w2) with | (NoNo, NoNo) -> Eq | (NoYes, NoYes) -> Eq | (YesNo, YesNo) -> Eq diff --git a/src/proto_013_PtJakart/lib_protocol/dependent_bool.mli b/src/proto_013_PtJakart/lib_protocol/dependent_bool.mli index 54416d9fd9c3e..a5265a36a14f0 100644 --- a/src/proto_013_PtJakart/lib_protocol/dependent_bool.mli +++ b/src/proto_013_PtJakart/lib_protocol/dependent_bool.mli @@ -46,7 +46,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] (** Logical conjunction of dependent booleans. *) val dand : 'a dbool -> 'b dbool -> ('a, 'b) ex_dand diff --git a/src/proto_013_PtJakart/lib_protocol/fees_storage.ml b/src/proto_013_PtJakart/lib_protocol/fees_storage.ml index 9a378f8eef8b5..ef02e16d2167a 100644 --- a/src/proto_013_PtJakart/lib_protocol/fees_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/fees_storage.ml @@ -78,7 +78,7 @@ let record_paid_storage_space ctxt contract = let source_must_exist c src = match src with - | `Contract src -> Contract_storage.must_exist c src + | Token.Source_container (Contract src) -> Contract_storage.must_exist c src | _ -> return_unit let burn_storage_fees ?(origin = Receipt_repr.Block_application) c @@ -97,7 +97,7 @@ let burn_storage_fees ?(origin = Receipt_repr.Block_application) c trace Cannot_pay_storage_fee ( source_must_exist c payer >>=? fun () -> - Token.transfer ~origin c payer `Storage_fees to_burn + Token.transfer ~origin c payer (Sink_infinite Storage_fees) to_burn >>=? fun (ctxt, balance_updates) -> return (ctxt, remaining, balance_updates) ) diff --git a/src/proto_013_PtJakart/lib_protocol/fitness_repr.ml b/src/proto_013_PtJakart/lib_protocol/fitness_repr.ml index 0a1c3bd7fa8af..5f9b73b1f605d 100644 --- a/src/proto_013_PtJakart/lib_protocol/fitness_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/fitness_repr.ml @@ -167,10 +167,10 @@ let locked_round_to_bytes = function | Some locked_round -> int32_to_bytes (Round_repr.to_int32 locked_round) let locked_round_of_bytes b = - match Bytes.length b with - | 0 -> ok None - | 4 -> Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) - | _ -> error Invalid_fitness + if Compare.Int.(Bytes.length b = 0) then ok None + else if Compare.Int.(Bytes.length b = 4) then + Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) + else error Invalid_fitness let predecessor_round_of_bytes neg_predecessor_round = int32_of_bytes neg_predecessor_round >>? fun neg_predecessor_round -> diff --git a/src/proto_013_PtJakart/lib_protocol/gas_comparable_input_size.ml b/src/proto_013_PtJakart/lib_protocol/gas_comparable_input_size.ml index 6e90810eba692..d82e68c242efb 100644 --- a/src/proto_013_PtJakart/lib_protocol/gas_comparable_input_size.ml +++ b/src/proto_013_PtJakart/lib_protocol/gas_comparable_input_size.ml @@ -106,37 +106,51 @@ let tx_rollup_l2_address x = let timestamp (tstamp : Alpha_context.Script_timestamp.t) : t = Z.numbits (Alpha_context.Script_timestamp.to_zint tstamp) / 8 -let rec size_of_comparable_value : +let[@coq_struct "wit"] rec size_of_comparable_value : type a. a Script_typed_ir.comparable_ty -> a -> t = fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) -> - match wit with - | Never_t -> ( match v with _ -> .) - | Unit_t -> unit - | Int_t -> integer v - | Nat_t -> integer v - | String_t -> script_string v - | Bytes_t -> bytes v - | Mutez_t -> mutez v - | Bool_t -> bool v - | Key_hash_t -> key_hash v - | Timestamp_t -> timestamp v - | Address_t -> address v - | Tx_rollup_l2_address_t -> tx_rollup_l2_address v - | Pair_t (leaf, node, _, YesYes) -> - let (lv, rv) = v in + match[@coq_match_gadt_with_result] [@coq_match_with_default] (wit, v) with + | (Never_t, _) -> ( + match ((v [@coq_cast]) : Script_typed_ir.never) with _ -> assert false) + | (Unit_t, _) -> unit + | (Int_t, _) -> + integer + ((v [@coq_cast]) + : Alpha_context.Script_int.z Alpha_context.Script_int.num) + | (Nat_t, _) -> + integer + ((v [@coq_cast]) + : Alpha_context.Script_int.n Alpha_context.Script_int.num) + | (String_t, _) -> + script_string ((v [@coq_cast]) : Alpha_context.Script_string.t) + | (Bytes_t, _) -> bytes ((v [@coq_cast]) : bytes) + | (Mutez_t, _) -> mutez ((v [@coq_cast]) : Tez_repr.t) + | (Bool_t, _) -> bool ((v [@coq_cast]) : bool) + | (Key_hash_t, _) -> key_hash ((v [@coq_cast]) : Signature.public_key_hash) + | (Timestamp_t, _) -> + timestamp ((v [@coq_cast]) : Alpha_context.Script_timestamp.t) + | (Address_t, _) -> address ((v [@coq_cast]) : Script_typed_ir.address) + | (Tx_rollup_l2_address_t, _) -> + tx_rollup_l2_address + ((v [@coq_cast]) : (_, Tx_rollup_l2_address.t) Indexable.t) + | (Pair_t (leaf, node, _, YesYes), _) -> + let (lv, rv) = ((v [@coq_cast]) : (_, _) Script_typed_ir.pair) in let size = size_of_comparable_value leaf lv + size_of_comparable_value node rv in size + 1 - | Union_t (left, right, _, YesYes) -> + | (Union_t (left, right, _, YesYes), _) -> let size = - match v with + match ((v [@coq_cast]) : (_, _) Script_typed_ir.union) with | L v -> size_of_comparable_value left v | R v -> size_of_comparable_value right v in size + 1 - | Option_t (ty, _, Yes) -> ( - match v with None -> 1 | Some x -> size_of_comparable_value ty x + 1) - | Signature_t -> signature v - | Key_t -> public_key v - | Chain_id_t -> chain_id v + | (Option_t (ty, _, Yes), _) -> ( + match ((v [@coq_cast]) : _ option) with + | None -> 1 + | Some x -> size_of_comparable_value ty x + 1) + | (Signature_t, _) -> signature ((v [@coq_cast]) : Script_typed_ir.signature) + | (Key_t, _) -> public_key ((v [@coq_cast]) : Signature.public_key) + | (Chain_id_t, _) -> + chain_id ((v [@coq_cast]) : Script_typed_ir.Script_chain_id.t) diff --git a/src/proto_013_PtJakart/lib_protocol/gas_input_size.ml b/src/proto_013_PtJakart/lib_protocol/gas_input_size.ml index bccdf39979e8e..3026abf4e27ef 100644 --- a/src/proto_013_PtJakart/lib_protocol/gas_input_size.ml +++ b/src/proto_013_PtJakart/lib_protocol/gas_input_size.ml @@ -52,7 +52,7 @@ let node leaves = let r = List.fold_left ( ++ ) micheline_zero leaves in {r with traversal = r.traversal + 1} -let rec of_micheline (x : ('a, 'b) Micheline.node) = +let[@coq_struct "x_value"] rec of_micheline (x : ('a, 'b) Micheline.node) = match x with | Micheline.Int (_loc, z) -> let int_bytes = integer (Alpha_context.Script_int.of_zint z) in diff --git a/src/proto_013_PtJakart/lib_protocol/gas_monad.ml b/src/proto_013_PtJakart/lib_protocol/gas_monad.ml index 1ab7a61495457..f71b026b7f321 100644 --- a/src/proto_013_PtJakart/lib_protocol/gas_monad.ml +++ b/src/proto_013_PtJakart/lib_protocol/gas_monad.ml @@ -47,7 +47,7 @@ let ( >>?? ) m f = let bind m f gas = m gas >>?? fun (res, gas) -> - match res with Ok y -> f y gas | Error _ as err -> of_result err gas + match res with Ok y -> f y gas | Error err -> of_result (Error err) gas [@@ocaml.inline always] let map f m gas = @@ -83,16 +83,16 @@ let run ctxt m = | None -> error Gas.Operation_quota_exceeded) let record_trace_eval : - type error_trace. + type a error_trace. error_details:error_trace Script_tc_errors.error_details -> (unit -> error) -> - ('a, error_trace) t -> - ('a, error_trace) t = - fun ~error_details -> - match error_details with - | Fast -> fun _f m -> m - | Informative -> - fun f m gas -> + (a, error_trace) t -> + (a, error_trace) t = + fun ~error_details f m -> + match[@coq_match_gadt_with_result] (error_details, m) with + | (Fast, _) -> m + | (Informative, (m : (_, _ trace) t)) -> + fun gas -> m gas >>?? fun (x, gas) -> of_result (record_trace_eval f x) gas let fail e = of_result (Error e) [@@ocaml.inline always] diff --git a/src/proto_013_PtJakart/lib_protocol/global_constants_storage.ml b/src/proto_013_PtJakart/lib_protocol/global_constants_storage.ml index 429b454d44f18..d06b23a720649 100644 --- a/src/proto_013_PtJakart/lib_protocol/global_constants_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/global_constants_storage.ml @@ -36,27 +36,27 @@ open Michelson_v1_primitives should move this function to lib_micheline. *) +let[@coq_struct "node_value"] rec traverse_node accu node f k = + f accu node @@ fun accu node -> + match node with + | String _ | Int _ | Bytes _ -> k accu node + | Prim (loc, prim, args, annot) -> + (traverse_nodes [@ocaml.tailcall]) accu args f @@ fun accu args -> + f accu (Prim (loc, prim, args, annot)) k + | Seq (loc, elts) -> + (traverse_nodes [@ocaml.tailcall]) accu elts f @@ fun accu elts -> + f accu (Seq (loc, elts)) k + +and[@coq_struct "nodes"] traverse_nodes accu nodes f k = + match nodes with + | [] -> k accu [] + | node :: nodes -> + (traverse_node [@ocaml.tailcall]) accu node f @@ fun accu node -> + (traverse_nodes [@ocaml.tailcall]) accu nodes f @@ fun accu nodes -> + k accu (node :: nodes) + let bottom_up_fold_cps initial_accumulator node initial_k f = - let rec traverse_node accu node k = - f accu node @@ fun accu node -> - match node with - | String _ | Int _ | Bytes _ -> k accu node - | Prim (loc, prim, args, annot) -> - (traverse_nodes [@ocaml.tailcall]) accu args @@ fun accu args -> - f accu (Prim (loc, prim, args, annot)) k - | Seq (loc, elts) -> - (traverse_nodes [@ocaml.tailcall]) accu elts @@ fun accu elts -> - f accu (Seq (loc, elts)) k - and traverse_nodes accu nodes k = - match nodes with - | [] -> k accu [] - | node :: nodes -> - (traverse_node [@ocaml.tailcall]) accu node @@ fun accu node -> - (traverse_nodes [@ocaml.tailcall]) accu nodes @@ fun accu nodes -> - k accu (node :: nodes) - in - traverse_node initial_accumulator node initial_k - [@@coq_axiom_with_reason "local mutually recursive definition not handled"] + traverse_node initial_accumulator node f initial_k module Gas_costs = Global_constants_costs module Expr_hash_map = Map.Make (Script_expr_hash) @@ -225,7 +225,7 @@ let expand context expr = with [Expression_too_deep] if greater than [max_allowed_global_constant_depth].*) let check_depth node = - let rec advance node depth k = + let[@coq_struct "node_value"] rec advance node depth k = if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth) then error Expression_too_deep else diff --git a/src/proto_013_PtJakart/lib_protocol/indexable.ml b/src/proto_013_PtJakart/lib_protocol/indexable.ml index 918e33f7d2164..9a103016a0f5b 100644 --- a/src/proto_013_PtJakart/lib_protocol/indexable.ml +++ b/src/proto_013_PtJakart/lib_protocol/indexable.ml @@ -93,9 +93,9 @@ let forget : type state a. (state, a) t -> (unknown, a) t = function | Hidden_value x | Value x -> Hidden_value x | Hidden_index x | Index x -> Hidden_index x -let to_int32 = function Index x -> x +let to_int32 = function[@coq_match_with_default] Index x -> x -let to_value = function Value x -> x +let to_value = function[@coq_match_with_default] Value x -> x let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = fun ~error v -> @@ -104,7 +104,8 @@ let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = let compact val_encoding = Data_encoding.Compact.( conv - (function Hidden_index x -> Either.Left x | Hidden_value x -> Right x) + (function[@coq_match_with_default] + | Hidden_index x -> Either.Left x | Hidden_value x -> Right x) (function Left x -> Hidden_index x | Right x -> Hidden_value x) @@ or_int32 ~int32_title:"index" ~alt_title:"value" val_encoding) @@ -148,10 +149,13 @@ let compare : | ((Hidden_value _ | Value _), (Hidden_index _ | Index _)) -> 1 let compare_values c : 'a value -> 'a value -> int = - fun (Value x) (Value y) -> c x y + fun x y -> + match[@coq_match_with_default] (x, y) with (Value x, Value y) -> c x y let compare_indexes : 'a index -> 'a index -> int = - fun (Index x) (Index y) -> Compare.Int32.compare x y + fun x y -> + match[@coq_match_with_default] (x, y) with + | (Index x, Index y) -> Compare.Int32.compare x y module type VALUE = sig type t @@ -163,7 +167,41 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) = struct +module type INDEXABLE = sig + type v_t + + type nonrec 'state t = ('state, v_t) t + + type nonrec index = v_t index + + type nonrec value = v_t value + + type nonrec either = v_t either + + val value : v_t -> value + + val index : int32 -> index tzresult + + val index_exn : int32 -> index + + val compact : either Data_encoding.Compact.t + + val encoding : either Data_encoding.t + + val index_encoding : index Data_encoding.t + + val value_encoding : value Data_encoding.t + + val compare : 'state t -> 'state' t -> int + + val compare_values : value -> value -> int + + val compare_indexes : index -> index -> int + + val pp : Format.formatter -> 'state t -> unit +end + +module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct type nonrec 'state t = ('state, V.t) t type nonrec index = V.t index @@ -172,28 +210,35 @@ module Make (V : VALUE) = struct type nonrec either = V.t either - let value = value + let value : V.t -> value = value - let index = index + let index : int32 -> index tzresult = index - let index_exn = index_exn + let index_exn : int32 -> index = index_exn - let compact = compact V.encoding + let compact : either Data_encoding.Compact.t = compact V.encoding - let encoding = encoding V.encoding + let encoding : either Data_encoding.t = encoding V.encoding let index_encoding : index Data_encoding.t = Data_encoding.( - conv (fun (Index x) -> x) (fun x -> Index x) Data_encoding.int32) + conv + (fun [@coq_match_with_default] (Index x) -> x) + (fun x -> Index x) + Data_encoding.int32) let value_encoding : value Data_encoding.t = - Data_encoding.(conv (fun (Value x) -> x) (fun x -> Value x) V.encoding) + Data_encoding.( + conv + (fun [@coq_match_with_default] (Value x) -> x) + (fun x -> Value x) + V.encoding) let pp : Format.formatter -> 'state t -> unit = fun fmt x -> pp V.pp fmt x - let compare_values = compare_values V.compare + let compare_values : value -> value -> int = compare_values V.compare - let compare_indexes = compare_indexes + let compare_indexes : index -> index -> int = compare_indexes let compare : 'state t -> 'state' t -> int = fun x y -> compare V.compare x y end diff --git a/src/proto_013_PtJakart/lib_protocol/indexable.mli b/src/proto_013_PtJakart/lib_protocol/indexable.mli index cc921e802f1f6..e71d8926bc4a5 100644 --- a/src/proto_013_PtJakart/lib_protocol/indexable.mli +++ b/src/proto_013_PtJakart/lib_protocol/indexable.mli @@ -162,16 +162,18 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) : sig - type nonrec 'state t = ('state, V.t) t +module type INDEXABLE = sig + type v_t - type nonrec index = V.t index + type nonrec 'state t = ('state, v_t) t - type nonrec value = V.t value + type nonrec index = v_t index - type nonrec either = V.t either + type nonrec value = v_t value - val value : V.t -> value + type nonrec either = v_t either + + val value : v_t -> value val index : int32 -> index tzresult @@ -194,4 +196,6 @@ module Make (V : VALUE) : sig val pp : Format.formatter -> 'state t -> unit end +module Make (V : VALUE) : INDEXABLE with type v_t := V.t + type error += Index_cannot_be_negative of int32 diff --git a/src/proto_013_PtJakart/lib_protocol/init_storage.ml b/src/proto_013_PtJakart/lib_protocol/init_storage.ml index a3b2b2997bb8d..94a16adc2813c 100644 --- a/src/proto_013_PtJakart/lib_protocol/init_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/init_storage.ml @@ -116,8 +116,8 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp = Commitment_repr.{blinded_public_key_hash; amount} = Token.transfer ctxt - `Initial_commitments - (`Collected_commitments blinded_public_key_hash) + (Source_infinite Initial_commitments) + (Sink_container (Collected_commitments blinded_public_key_hash)) amount >>=? fun (ctxt, new_balance_updates) -> return (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_013_PtJakart/lib_protocol/lazy_storage_diff.ml b/src/proto_013_PtJakart/lib_protocol/lazy_storage_diff.ml index 9a7030c357412..eb70536a55945 100644 --- a/src/proto_013_PtJakart/lib_protocol/lazy_storage_diff.ml +++ b/src/proto_013_PtJakart/lib_protocol/lazy_storage_diff.ml @@ -183,10 +183,9 @@ end *) let get_ops : type i a u. (i, a, u) Lazy_storage_kind.t -> (i, a, u) ops = - function + function[@coq_match_gadt_with_result] | Big_map -> (module Big_map) | Sapling_state -> (module Sapling_state) - [@@coq_axiom_with_reason "gadt"] type ('id, 'alloc) init = Existing | Copy of {src : 'id} | Alloc of 'alloc @@ -354,7 +353,7 @@ let item_encoding = let open Data_encoding in union @@ List.map - (fun (tag, Lazy_storage_kind.Ex_Kind k) -> + (fun [@coq_match_gadt] (tag, Lazy_storage_kind.Ex_Kind k) -> let ops = get_ops k in let (module OPS) = ops in let title = OPS.title in @@ -366,12 +365,13 @@ let item_encoding = (req "id" OPS.Id.encoding) (req "diff" (diff_encoding ops))) (fun (Item (kind, id, diff)) -> - match Lazy_storage_kind.equal k kind with + match[@coq_match_gadt_with_result] + Lazy_storage_kind.equal k kind + with | Eq -> Some ((), id, diff) - | Neq -> None) + | Neq -> None [@coq_type_annotation]) (fun ((), id, diff) -> Item (k, id, diff))) Lazy_storage_kind.all - [@@coq_axiom_with_reason "gadt"] let item_in_memory_size (Item @@ -414,26 +414,28 @@ let fresh : (Raw_context.fold_map_temporary_lazy_storage_ids ctxt (fun temp_ids -> Lazy_storage_kind.Temp_ids.fresh kind temp_ids)) else - let (module OPS) = get_ops kind in - OPS.Next.incr ctxt - [@@coq_axiom_with_reason "gadt"] + match[@coq_match_gadt] kind with + | kind -> + let m = get_ops kind in + let (module OPS) = (m [@coq_type_annotation]) in + OPS.Next.incr ctxt let init ctxt = List.fold_left_es - (fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) -> - let (module OPS) = get_ops k in - OPS.Next.init ctxt) + (fun ctxt -> + fun [@coq_match_gadt] (_tag, Lazy_storage_kind.Ex_Kind k) -> + let (module OPS) = (get_ops k [@coq_type_annotation]) in + OPS.Next.init ctxt) ctxt Lazy_storage_kind.all - [@@coq_axiom_with_reason "gadt"] let cleanup_temporaries ctxt = Raw_context.map_temporary_lazy_storage_ids_s ctxt (fun temp_ids -> List.fold_left_s - (fun ctxt (_tag, Lazy_storage_kind.Ex_Kind k) -> - let (module OPS) = get_ops k in - Lazy_storage_kind.Temp_ids.fold_s k OPS.remove temp_ids ctxt) + (fun ctxt -> + fun [@coq_match_gadt] (_tag, Lazy_storage_kind.Ex_Kind k) -> + let (module OPS) = (get_ops k [@coq_type_annotation]) in + Lazy_storage_kind.Temp_ids.fold_s k OPS.remove temp_ids ctxt) ctxt Lazy_storage_kind.all >|= fun ctxt -> (ctxt, Lazy_storage_kind.Temp_ids.init)) - [@@coq_axiom_with_reason "gadt"] diff --git a/src/proto_013_PtJakart/lib_protocol/lazy_storage_kind.ml b/src/proto_013_PtJakart/lib_protocol/lazy_storage_kind.ml index 799e55e047f7d..e9b2126254a4f 100644 --- a/src/proto_013_PtJakart/lib_protocol/lazy_storage_kind.ml +++ b/src/proto_013_PtJakart/lib_protocol/lazy_storage_kind.ml @@ -240,7 +240,7 @@ module Temp_ids = struct let fresh : type i a u. (i, a, u) kind -> t -> t * i = fun kind temp_ids -> - match kind with + match[@coq_match_gadt_with_result] kind with | Big_map -> let big_map = Big_map.Temp_id.next temp_ids.big_map in ({temp_ids with big_map}, (temp_ids.big_map :> Big_map.Id.t)) @@ -248,31 +248,29 @@ module Temp_ids = struct let sapling_state = Sapling_state.Temp_id.next temp_ids.sapling_state in ( {temp_ids with sapling_state}, (temp_ids.sapling_state :> Sapling_state.Id.t) ) - [@@coq_axiom_with_reason "gadt"] let fold_s : - type i a u. - (i, a, u) kind -> ('acc -> i -> 'acc Lwt.t) -> t -> 'acc -> 'acc Lwt.t = + type i a u acc. + (i, a, u) kind -> (acc -> i -> acc Lwt.t) -> t -> acc -> acc Lwt.t = fun kind f temp_ids acc -> let helper (type j) (module Temp_id : TEMP_ID with type t = j) ~last f = - let rec aux acc id = + let[@coq_struct "id"] rec aux acc id = if Temp_id.equal id last then Lwt.return acc else f acc id >>= fun acc -> aux acc (Temp_id.next id) in aux acc Temp_id.init in - match kind with - | Big_map -> + match[@coq_match_gadt] (kind, f) with + | (Big_map, (f : _ -> Big_map.Id.t -> _)) -> helper (module Big_map.Temp_id) ~last:temp_ids.big_map (fun acc temp_id -> f acc (temp_id :> i)) - | Sapling_state -> + | (Sapling_state, (f : _ -> Sapling_state.Id.t -> _)) -> helper (module Sapling_state.Temp_id) ~last:temp_ids.sapling_state (fun acc temp_id -> f acc (temp_id :> i)) - [@@coq_axiom_with_reason "gadt"] end module IdSet = struct @@ -284,21 +282,20 @@ module IdSet = struct {big_map = Big_map.IdSet.empty; sapling_state = Sapling_state.IdSet.empty} let mem (type i a u) (kind : (i, a, u) kind) (id : i) set = - match (kind, set) with - | (Big_map, {big_map; _}) -> Big_map.IdSet.mem id big_map - | (Sapling_state, {sapling_state; _}) -> + match[@coq_match_gadt] (kind, id, set) with + | (Big_map, (id : Big_map.Id.t), {big_map; _}) -> + Big_map.IdSet.mem id big_map + | (Sapling_state, (id : Sapling_state.Id.t), {sapling_state; _}) -> Sapling_state.IdSet.mem id sapling_state - [@@coq_axiom_with_reason "gadt"] let add (type i a u) (kind : (i, a, u) kind) (id : i) set = - match (kind, set) with - | (Big_map, {big_map; _}) -> + match[@coq_match_gadt] (kind, id, set) with + | (Big_map, (id : Big_map.Id.t), {big_map; _}) -> let big_map = Big_map.IdSet.add id big_map in {set with big_map} - | (Sapling_state, {sapling_state; _}) -> + | (Sapling_state, (id : Sapling_state.Id.t), {sapling_state; _}) -> let sapling_state = Sapling_state.IdSet.add id sapling_state in {set with sapling_state} - [@@coq_axiom_with_reason "gadt"] let diff set1 set2 = let big_map = Big_map.IdSet.diff set1.big_map set2.big_map in @@ -306,20 +303,20 @@ module IdSet = struct Sapling_state.IdSet.diff set1.sapling_state set2.sapling_state in {big_map; sapling_state} - [@@coq_axiom_with_reason "gadt"] - let fold (type i a u) (kind : (i, a, u) kind) (f : i -> 'acc -> 'acc) set - (acc : 'acc) = - match (kind, set) with - | (Big_map, {big_map; _}) -> Big_map.IdSet.fold f big_map acc - | (Sapling_state, {sapling_state; _}) -> + let fold (type i a u acc) (kind : (i, a, u) kind) (f : i -> acc -> acc) set + (acc : acc) = + match[@coq_match_gadt] (kind, f, set) with + | (Big_map, (f : Big_map.Id.t -> _ -> _), {big_map; _}) -> + Big_map.IdSet.fold f big_map acc + | (Sapling_state, (f : Sapling_state.Id.t -> _ -> _), {sapling_state; _}) -> Sapling_state.IdSet.fold f sapling_state acc - [@@coq_axiom_with_reason "gadt"] let fold_all f set acc = List.fold_left - (fun acc (_, Ex_Kind kind) -> fold kind (f.f kind) set acc) + (fun acc -> function[@coq_match_gadt] + | (_, Ex_Kind (kind : _ kind)) -> + (fold [@coq_implicit "i" "__Ex_Kind"]) kind (f.f kind) set acc) acc all - [@@coq_axiom_with_reason "gadt"] end diff --git a/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml b/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml index e7355d3ebfc9b..d5b8622266025 100644 --- a/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml +++ b/src/proto_013_PtJakart/lib_protocol/legacy_script_patches_for_J.ml @@ -162,7 +162,9 @@ let expru1ukk6ZqdA32rFYFG7j1eGjfsatbdUZWz8Mi1kXWZYRZm4FZVe = ]; patched_code = bin_expr_exn - "0200002f0405000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c05020200002b61055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001e3d072e0200000b73072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009a6051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000012be072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000009a7072e020000049c051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b034202000004ff051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d05700002031b034c031b03420200000c59072e0200000867072e0200000517051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103170317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342"; + ("0200002f0405000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c05020200002b61055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001e3d072e0200000b73072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009a6051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000012be072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000" + ^ "b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000009a7072e020000049c051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b034202000004ff051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d05700002031b034c031b03420200000c59072e0200000867072e0200000517051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103170317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342" + ); } let exprubv5oQmAUP8BwktmDgMWqTizYDJVhzHhJESGZhJ2GkHESZ1VWg = @@ -173,7 +175,9 @@ let exprubv5oQmAUP8BwktmDgMWqTizYDJVhzHhJESGZhJ2GkHESZ1VWg = addresses = ["KT1CT7S2b9hXNRxRrEcany9sak1qe4aaFAZJ"]; patched_code = bin_expr_exn - "0200002c6905000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c050202000028c6055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001c86072e0200000b8d072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009c0051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e032703130743036a000003190337072c0200000000020000004607430368010000003b54686520616d6f756e74206f662058545a2073656e7420746f20446578746572206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000010ed072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000007d6072e02000003af051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b0342020000041b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b034c031b03420200000b75072e0200000783072e0200000433051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342"; + ("0200002c6905000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c050202000028c6055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001c86072e0200000b8d072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009c0051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e032703130743036a000003190337072c0200000000020000004607430368010000003b54686520616d6f756e74206f662058545a2073656e7420746f20446578746572206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000010ed072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000" + ^ "203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000007d6072e02000003af051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b0342020000041b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b034c031b03420200000b75072e0200000783072e0200000433051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342" + ); } let patches = diff --git a/src/proto_013_PtJakart/lib_protocol/level_repr.ml b/src/proto_013_PtJakart/lib_protocol/level_repr.ml index 0b5926f387f57..cc16715354fcb 100644 --- a/src/proto_013_PtJakart/lib_protocol/level_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/level_repr.ml @@ -130,7 +130,8 @@ let create_cycle_eras cycle_eras = match cycle_eras with | [] -> error Invalid_cycle_eras | newest_era :: older_eras -> - let rec aux {first_level; first_cycle; _} older_eras = + let rec aux era older_eras = + let {first_level; first_cycle; _} = era in match older_eras with | ({ first_level = first_level_of_previous_era; diff --git a/src/proto_013_PtJakart/lib_protocol/level_storage.ml b/src/proto_013_PtJakart/lib_protocol/level_storage.ml index 526e64e963887..53f5a46402551 100644 --- a/src/proto_013_PtJakart/lib_protocol/level_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/level_storage.ml @@ -73,7 +73,7 @@ let last_level_in_cycle ctxt c = let levels_in_cycle ctxt cycle = let first = first_level_in_cycle ctxt cycle in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc) else acc in @@ -89,7 +89,7 @@ let levels_in_current_cycle ctxt ?(offset = 0l) () = let levels_with_commitments_in_cycle ctxt c = let first = first_level_in_cycle ctxt c in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then if n.expected_commitment then loop (succ ctxt n) (n :: acc) else loop (succ ctxt n) acc diff --git a/src/proto_013_PtJakart/lib_protocol/liquidity_baking_migration.ml b/src/proto_013_PtJakart/lib_protocol/liquidity_baking_migration.ml index bdc133bd0134f..68a4d450ec901 100644 --- a/src/proto_013_PtJakart/lib_protocol/liquidity_baking_migration.ml +++ b/src/proto_013_PtJakart/lib_protocol/liquidity_baking_migration.ml @@ -122,20 +122,20 @@ let originate ctxt address ~balance script = ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) >>=? fun (ctxt, _, origination_updates) -> Fees_storage.burn_storage_fees ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) size >>=? fun (ctxt, _, storage_updates) -> Token.transfer ~origin:Protocol_migration ctxt - `Liquidity_baking_subsidies - (`Contract address) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract address)) balance >>=? fun (ctxt, transfer_updates) -> let balance_updates = diff --git a/src/proto_013_PtJakart/lib_protocol/main.ml b/src/proto_013_PtJakart/lib_protocol/main.ml index e4a4230232a2d..60ea8f638c0ae 100644 --- a/src/proto_013_PtJakart/lib_protocol/main.ml +++ b/src/proto_013_PtJakart/lib_protocol/main.ml @@ -813,4 +813,4 @@ let precheck_manager {ctxt; _} op = * 'kind Alpha_context.Kind.manager Apply_results.prechecked_contents_list) -> () -(* Vanity nonce: 3377969936514094 *) +(* Vanity nonce: 4199792028500268 *) diff --git a/src/proto_013_PtJakart/lib_protocol/merkle_list.ml b/src/proto_013_PtJakart/lib_protocol/merkle_list.ml index 88da122fa3146..41aff5ffbea7f 100644 --- a/src/proto_013_PtJakart/lib_protocol/merkle_list.ml +++ b/src/proto_013_PtJakart/lib_protocol/merkle_list.ml @@ -88,12 +88,14 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t = struct +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t = +struct type h = H.t type elt = El.t @@ -145,7 +147,7 @@ end) let empty = H.zero - let root = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h + let root_aux = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h let nil = {tree = Empty; depth = 0; next_pos = 0} @@ -155,7 +157,7 @@ end) let hash2 h1 h2 = H.(hash_bytes [to_bytes h1; to_bytes h2]) - let node_of t1 t2 = Node (hash2 (root t1) (root t2), t1, t2) + let node_of t1 t2 = Node (hash2 (root_aux t1) (root_aux t2), t1, t2) (* to_bin computes the [depth]-long binary representation of [pos] (left-padding with 0s if required). This corresponds to the tree traversal @@ -164,25 +166,25 @@ end) Pre-condition: pos >= 0 /| pos < 2^depth Post-condition: len(to_bin pos depth) = depth *) let to_bin ~pos ~depth = - let rec aux acc pos depth = + let[@coq_struct "depth"] rec aux acc pos depth = let (pos', dir) = (pos / 2, pos mod 2) in match depth with | 0 -> acc | d -> aux (Compare.Int.(dir = 1) :: acc) pos' (d - 1) in - aux [] pos depth + aux List.nil pos depth (* Constructs a tree of a given depth in which every right subtree is empty * and the only leaf contains the hash of el. *) let make_spine_with el = - let rec aux left = function + let[@coq_struct "function_parameter"] rec aux left = function | 0 -> left | d -> (aux [@tailcall]) (node_of left Empty) (d - 1) in aux (leaf_of el) let snoc t (el : elt) = - let rec traverse tree depth key = + let[@coq_struct "depth"] rec traverse tree depth key = match (tree, key) with | (Node (_, t_left, Empty), true :: _key) -> (* The base case where the left subtree is full and we start @@ -209,13 +211,13 @@ end) let (tree', depth') = match (t.tree, t.depth, t.next_pos) with | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) - | (tree, depth, pos) when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) | (tree, depth, pos) -> - let key = to_bin ~pos ~depth in - (traverse tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} @@ -248,18 +250,18 @@ end) let (tree', depth') = match (t.tree, t.depth, t.next_pos) with | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) - | (tree, depth, pos) when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) | (tree, depth, pos) -> - let key = to_bin ~pos ~depth in - (traverse Top tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse Top tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} let rec tree_to_list = function - | Empty -> [] + | Empty -> List.nil | Leaf h -> [h] | Node (_, t_left, t_right) -> tree_to_list t_left @ tree_to_list t_right @@ -280,10 +282,11 @@ end) match (tree, key) with | (Leaf _, []) -> ok acc | (Node (_, l, r), b :: key) -> - if b then aux (root l :: acc) r key else aux (root r :: acc) l key + if b then aux (root_aux l :: acc) r key + else aux (root_aux r :: acc) l key | _ -> error Merkle_list_invalid_position in - aux [] tree key + aux List.nil tree key let check_path path pos el expected_root = let depth = List.length path in @@ -305,17 +308,17 @@ end) let path_depth path = List.length path let compute l = - let rec aux l = + let[@coq_struct "l_value"] rec aux l = let rec pairs acc = function | [] -> List.rev acc | [x] -> List.rev (hash2 x empty :: acc) | x :: y :: xs -> pairs (hash2 x y :: acc) xs in - match pairs [] l with [] -> empty | [h] -> h | pl -> aux pl + match pairs List.nil l with [] -> empty | [h] -> h | pl -> aux pl in aux (List.map hash_elt l) - let root t = root t.tree + let root t = root_aux t.tree module Internal_for_tests = struct let path_to_list x = x diff --git a/src/proto_013_PtJakart/lib_protocol/merkle_list.mli b/src/proto_013_PtJakart/lib_protocol/merkle_list.mli index 2352d451b7738..8a40dbe749eee 100644 --- a/src/proto_013_PtJakart/lib_protocol/merkle_list.mli +++ b/src/proto_013_PtJakart/lib_protocol/merkle_list.mli @@ -107,9 +107,10 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t diff --git a/src/proto_013_PtJakart/lib_protocol/michelson_v1_gas.ml b/src/proto_013_PtJakart/lib_protocol/michelson_v1_gas.ml index e90457877268c..060650fd7ee33 100644 --- a/src/proto_013_PtJakart/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_013_PtJakart/lib_protocol/michelson_v1_gas.ml @@ -1384,65 +1384,109 @@ module Cost_of = struct | Compare : 'a Script_typed_ir.comparable_ty * 'a * 'a * cont -> cont | Return : cont + let[@coq_struct "ty"] rec compare_aux : + type a. + a Script_typed_ir.comparable_ty -> a -> a -> cost -> cont -> cost = + fun ty x y acc k -> + match[@coq_match_gadt_with_result] [@coq_match_with_default] ty with + | Unit_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_unit) k + | Never_t -> ( match x with _ -> assert false) + | Bool_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_bool) k + | String_t -> + (apply_aux [@tailcall]) + Gas.( + acc + +@ compare_string + ((x [@coq_cast]) : Alpha_context.Script_string.t) + ((y [@coq_cast]) : Alpha_context.Script_string.t)) + k + | Signature_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_signature) k + | Bytes_t -> + (apply_aux [@tailcall]) + Gas.( + acc + +@ compare_bytes + ((x [@coq_cast]) : bytes) + ((y [@coq_cast]) : bytes)) + k + | Mutez_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_mutez) k + | Int_t -> + (apply_aux [@tailcall]) + Gas.( + acc + +@ compare_int + ((x [@coq_cast]) + : Alpha_context.Script_int.z Alpha_context.Script_int.num) + ((y [@coq_cast]) + : Alpha_context.Script_int.z Alpha_context.Script_int.num)) + k + | Nat_t -> + (apply_aux [@tailcall]) + Gas.( + acc + +@ compare_nat + ((x [@coq_cast]) + : Alpha_context.Script_int.n Alpha_context.Script_int.num) + ((y [@coq_cast]) + : Alpha_context.Script_int.n Alpha_context.Script_int.num)) + k + | Key_hash_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_key_hash) k + | Key_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_key) k + | Timestamp_t -> + (apply_aux [@tailcall]) + Gas.( + acc + +@ compare_timestamp + ((x [@coq_cast]) : Alpha_context.Script_timestamp.t) + ((y [@coq_cast]) : Alpha_context.Script_timestamp.t)) + k + | Address_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_address) k + | Tx_rollup_l2_address_t -> + (apply_aux [@tailcall]) Gas.(acc +@ compare_tx_rollup_l2_address) k + | Chain_id_t -> (apply_aux [@tailcall]) Gas.(acc +@ compare_chain_id) k + | Pair_t (tl, tr, _, YesYes) -> + (* Reasonable over-approximation of the cost of lexicographic comparison. *) + let (xl, xr) = ((x [@coq_cast]) : (_, _) Script_typed_ir.pair) in + let (yl, yr) = ((y [@coq_cast]) : (_, _) Script_typed_ir.pair) in + (compare_aux [@tailcall]) + tl + xl + yl + Gas.(acc +@ compare_pair_tag) + (Compare (tr, xr, yr, k)) + | Union_t (tl, tr, _, YesYes) -> ( + match + ( ((x [@coq_cast]) : (_, _) Script_typed_ir.union), + ((y [@coq_cast]) : (_, _) Script_typed_ir.union) ) + with + | (L x, L y) -> + (compare_aux [@tailcall]) tl x y Gas.(acc +@ compare_union_tag) k + | (L _, R _) -> + (apply_aux [@tailcall]) Gas.(acc +@ compare_union_tag) k + | (R _, L _) -> + (apply_aux [@tailcall]) Gas.(acc +@ compare_union_tag) k + | (R x, R y) -> + (compare_aux [@tailcall]) tr x y Gas.(acc +@ compare_union_tag) k) + | Option_t (t, _, Yes) -> ( + match + (((x [@coq_cast]) : _ option), ((y [@coq_cast]) : _ option)) + with + | (None, None) -> + (apply_aux [@tailcall]) Gas.(acc +@ compare_option_tag) k + | (None, Some _) -> + (apply_aux [@tailcall]) Gas.(acc +@ compare_option_tag) k + | (Some _, None) -> + (apply_aux [@tailcall]) Gas.(acc +@ compare_option_tag) k + | (Some x, Some y) -> + (compare_aux [@tailcall]) t x y Gas.(acc +@ compare_option_tag) k) + + and[@coq_struct "k_value"] apply_aux cost k = + match k with + | Compare (ty, x, y, k) -> (compare_aux [@tailcall]) ty x y cost k + | Return -> cost + let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost = - fun ty x y -> - let rec compare : - type a. - a Script_typed_ir.comparable_ty -> a -> a -> cost -> cont -> cost = - fun ty x y acc k -> - match ty with - | Unit_t -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k - | Never_t -> ( match x with _ -> .) - | Bool_t -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k - | String_t -> (apply [@tailcall]) Gas.(acc +@ compare_string x y) k - | Signature_t -> (apply [@tailcall]) Gas.(acc +@ compare_signature) k - | Bytes_t -> (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k - | Mutez_t -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k - | Int_t -> (apply [@tailcall]) Gas.(acc +@ compare_int x y) k - | Nat_t -> (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k - | Key_hash_t -> (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k - | Key_t -> (apply [@tailcall]) Gas.(acc +@ compare_key) k - | Timestamp_t -> - (apply [@tailcall]) Gas.(acc +@ compare_timestamp x y) k - | Address_t -> (apply [@tailcall]) Gas.(acc +@ compare_address) k - | Tx_rollup_l2_address_t -> - (apply [@tailcall]) Gas.(acc +@ compare_tx_rollup_l2_address) k - | Chain_id_t -> (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k - | Pair_t (tl, tr, _, YesYes) -> - (* Reasonable over-approximation of the cost of lexicographic comparison. *) - let (xl, xr) = x in - let (yl, yr) = y in - (compare [@tailcall]) - tl - xl - yl - Gas.(acc +@ compare_pair_tag) - (Compare (tr, xr, yr, k)) - | Union_t (tl, tr, _, YesYes) -> ( - match (x, y) with - | (L x, L y) -> - (compare [@tailcall]) tl x y Gas.(acc +@ compare_union_tag) k - | (L _, R _) -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k - | (R _, L _) -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k - | (R x, R y) -> - (compare [@tailcall]) tr x y Gas.(acc +@ compare_union_tag) k) - | Option_t (t, _, Yes) -> ( - match (x, y) with - | (None, None) -> - (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k - | (None, Some _) -> - (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k - | (Some _, None) -> - (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k - | (Some x, Some y) -> - (compare [@tailcall]) t x y Gas.(acc +@ compare_option_tag) k) - and apply cost k = - match k with - | Compare (ty, x, y, k) -> (compare [@tailcall]) ty x y cost k - | Return -> cost - in - compare ty x y Gas.free Return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] + fun ty x y -> compare_aux ty x y Gas.free Return let set_mem (type a) (elt : a) (set : a Script_typed_ir.set) = let open S_syntax in diff --git a/src/proto_013_PtJakart/lib_protocol/michelson_v1_primitives.ml b/src/proto_013_PtJakart/lib_protocol/michelson_v1_primitives.ml index b85b7ea065986..b526288691505 100644 --- a/src/proto_013_PtJakart/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_013_PtJakart/lib_protocol/michelson_v1_primitives.ml @@ -551,8 +551,10 @@ let prim_of_string = function else error (Invalid_case n) let prims_of_strings expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> ok expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> ok (Int (l, z)) + | String (l, s) -> ok (String (l, s)) + | Bytes (l, b) -> ok (Bytes (l, b)) | Prim (loc, prim, args, annot) -> Error_monad.record_trace (Invalid_primitive_name (expr, loc)) @@ -562,12 +564,12 @@ let prims_of_strings expr = | Seq (loc, args) -> List.map_e convert args >|? fun args -> Seq (loc, args) in convert (root expr) >|? fun expr -> strip_locations expr - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let strings_of_prims expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> Int (l, z) + | String (l, s) -> String (l, s) + | Bytes (l, b) -> Bytes (l, b) | Prim (loc, prim, args, annot) -> let prim = string_of_prim prim in let args = List.map convert args in @@ -577,8 +579,6 @@ let strings_of_prims expr = Seq (loc, args) in strip_locations (convert (root expr)) - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let prim_encoding = let open Data_encoding in diff --git a/src/proto_013_PtJakart/lib_protocol/misc.ml b/src/proto_013_PtJakart/lib_protocol/misc.ml index bd350a5ef85b2..8909551aeb1e2 100644 --- a/src/proto_013_PtJakart/lib_protocol/misc.ml +++ b/src/proto_013_PtJakart/lib_protocol/misc.ml @@ -31,39 +31,46 @@ type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t -let[@coq_struct "i"] rec ( --> ) i j = +let[@coq_struct "i_value"] rec ( --> ) i j = (* [i; i+1; ...; j] *) if Compare.Int.(i > j) then [] else i :: (succ i --> j) -let[@coq_struct "j"] rec ( <-- ) i j = +let[@coq_struct "j_value"] rec ( <-- ) i j = (* [j; j-1; ...; i] *) if Compare.Int.(i > j) then [] else j :: (i <-- pred j) -let[@coq_struct "i"] rec ( ---> ) i j = +let[@coq_struct "i_value"] rec ( ---> ) i j = (* [i; i+1; ...; j] *) if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j) -let split delim ?(limit = max_int) path = - let l = String.length path in - let rec do_slashes acc limit i = +module Split = struct + let[@coq_struct "i_value"] rec do_slashes env acc limit i = + let (delim, path, l) = env in if Compare.Int.(i >= l) then List.rev acc - else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1) - else do_split acc limit i - and do_split acc limit i = + else if Compare.Char.(path.[i] = delim) then do_slashes env acc limit (i + 1) + else do_split env acc limit i + + and[@coq_struct "limit"] do_split env acc limit i = + let (_, path, l) = env in if Compare.Int.(limit <= 0) then if Compare.Int.(i = l) then List.rev acc else List.rev (String.sub path i (l - i) :: acc) - else do_component acc (pred limit) i i - and do_component acc limit i j = + else do_component env acc (pred limit) i i + + and[@coq_struct "j_value"] do_component env acc limit i j = + let (delim, path, l) = env in if Compare.Int.(j >= l) then if Compare.Int.(i = j) then List.rev acc else List.rev (String.sub path i (j - i) :: acc) else if Compare.Char.(path.[j] = delim) then - do_slashes (String.sub path i (j - i) :: acc) limit j - else do_component acc limit i (j + 1) - in - if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path] - [@@coq_axiom_with_reason "non-top-level mutual recursion"] + do_slashes env (String.sub path i (j - i) :: acc) limit j + else do_component env acc limit i (j + 1) +end + +let split delim ?(limit = max_int) path = + let l = String.length path in + let env = (delim, path, l) in + if Compare.Int.(limit > 0) then Split.do_slashes env [] limit 0 else [path] let pp_print_paragraph ppf description = Format.fprintf diff --git a/src/proto_013_PtJakart/lib_protocol/operation_repr.ml b/src/proto_013_PtJakart/lib_protocol/operation_repr.ml index dec9abba76d0d..f2b2788214857 100644 --- a/src/proto_013_PtJakart/lib_protocol/operation_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/operation_repr.ml @@ -42,6 +42,7 @@ module Kind = struct type 'a double_consensus_operation_evidence = | Double_consensus_operation_evidence + [@@coq_force_gadt] type double_endorsement_evidence = endorsement_consensus_kind double_consensus_operation_evidence @@ -122,15 +123,16 @@ module Kind = struct | Sc_rollup_publish_manager_kind : sc_rollup_publish manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type = struct + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -let pp_operation_kind (type kind) ppf - (operation_kind : kind consensus_operation_type) = - match operation_kind with - | Endorsement -> Format.fprintf ppf "Endorsement" - | Preendorsement -> Format.fprintf ppf "Preendorsement" + let pp (type kind) ppf (operation_kind : kind t) = + match operation_kind with + | Endorsement -> Format.fprintf ppf "Endorsement" + | Preendorsement -> Format.fprintf ppf "Preendorsement" +end type consensus_content = { slot : Slot_repr.t; @@ -171,12 +173,12 @@ let pp_consensus_content ppf content = Block_payload_hash.pp_short content.block_payload_hash -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t +module Consensus_watermark = struct + type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t +end let bytes_of_consensus_watermark = function - | Preendorsement chain_id -> + | Consensus_watermark.Preendorsement chain_id -> Bytes.cat (Bytes.of_string "\x12") (Chain_id.to_bytes chain_id) | Endorsement chain_id -> Bytes.cat (Bytes.of_string "\x13") (Chain_id.to_bytes chain_id) @@ -189,11 +191,11 @@ let of_watermark = function match Bytes.get b 0 with | '\x12' -> Option.map - (fun chain_id -> Endorsement chain_id) + (fun chain_id -> Consensus_watermark.Endorsement chain_id) (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1))) | '\x13' -> Option.map - (fun chain_id -> Preendorsement chain_id) + (fun chain_id -> Consensus_watermark.Preendorsement chain_id) (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1))) | _ -> None else None @@ -216,75 +218,7 @@ type origination = { credit : Tez_repr.tez; } -type 'kind operation = { - shell : Operation.shell_header; - protocol_data : 'kind protocol_data; -} - -and 'kind protocol_data = { - contents : 'kind contents_list; - signature : Signature.t option; -} - -and _ contents_list = - | Single : 'kind contents -> 'kind contents_list - | Cons : - 'kind Kind.manager contents * 'rest Kind.manager contents_list - -> ('kind * 'rest) Kind.manager contents_list - -and _ contents = - | Preendorsement : consensus_content -> Kind.preendorsement contents - | Endorsement : consensus_content -> Kind.endorsement contents - | Seed_nonce_revelation : { - level : Raw_level_repr.t; - nonce : Seed_repr.nonce; - } - -> Kind.seed_nonce_revelation contents - | Double_preendorsement_evidence : { - op1 : Kind.preendorsement operation; - op2 : Kind.preendorsement operation; - } - -> Kind.double_preendorsement_evidence contents - | Double_endorsement_evidence : { - op1 : Kind.endorsement operation; - op2 : Kind.endorsement operation; - } - -> Kind.double_endorsement_evidence contents - | Double_baking_evidence : { - bh1 : Block_header_repr.t; - bh2 : Block_header_repr.t; - } - -> Kind.double_baking_evidence contents - | Activate_account : { - id : Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - } - -> Kind.activate_account contents - | Proposals : { - source : Signature.Public_key_hash.t; - period : int32; - proposals : Protocol_hash.t list; - } - -> Kind.proposals contents - | Ballot : { - source : Signature.Public_key_hash.t; - period : int32; - proposal : Protocol_hash.t; - ballot : Vote_repr.ballot; - } - -> Kind.ballot contents - | Failing_noop : string -> Kind.failing_noop contents - | Manager_operation : { - source : Signature.public_key_hash; - fee : Tez_repr.tez; - counter : counter; - operation : 'kind manager_operation; - gas_limit : Gas_limit_repr.Arith.integral; - storage_limit : Z.t; - } - -> 'kind Kind.manager contents - -and _ manager_operation = +type _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : transaction -> Kind.transaction manager_operation | Origination : origination -> Kind.origination manager_operation @@ -374,7 +308,75 @@ and _ manager_operation = } -> Kind.sc_rollup_publish manager_operation -and counter = Z.t +type counter = Z.t + +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +and _ contents = + | Preendorsement : consensus_content -> Kind.preendorsement contents + | Endorsement : consensus_content -> Kind.endorsement contents + | Seed_nonce_revelation : { + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents + | Double_preendorsement_evidence : { + op1 : Kind.preendorsement operation; + op2 : Kind.preendorsement operation; + } + -> Kind.double_preendorsement_evidence contents + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents + | Failing_noop : string -> Kind.failing_noop contents + | Manager_operation : { + source : Signature.public_key_hash; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas_limit_repr.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents let manager_kind : type kind. kind manager_operation -> kind Kind.manager = function @@ -506,20 +508,20 @@ module Encoding = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = MCase { tag = 0; name = "reveal"; encoding = obj1 (req "public_key" Signature.Public_key.encoding); select = (function Manager (Reveal _ as op) -> Some op | _ -> None); - proj = (function Reveal pkh -> pkh); + proj = (function[@coq_match_with_default] Reveal pkh -> pkh); inj = (fun pkh -> Reveal pkh); } let transaction_tag = 1 - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = MCase { tag = transaction_tag; @@ -536,7 +538,7 @@ module Encoding = struct select = (function Manager (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -558,7 +560,7 @@ module Encoding = struct let origination_tag = 2 - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = MCase { tag = origination_tag; @@ -571,7 +573,7 @@ module Encoding = struct select = (function Manager (Origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = @@ -581,7 +583,7 @@ module Encoding = struct let delegation_tag = 3 - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = MCase { tag = delegation_tag; @@ -589,11 +591,11 @@ module Encoding = struct encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); select = (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); + proj = (function[@coq_match_with_default] Delegation key -> key); inj = (fun key -> Delegation key); } - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = MCase { tag = 4; @@ -602,11 +604,13 @@ module Encoding = struct select = (function | Manager (Register_global_constant _ as op) -> Some op | _ -> None); - proj = (function Register_global_constant {value} -> value); + proj = + (function[@coq_match_with_default] + | Register_global_constant {value} -> value); inj = (fun value -> Register_global_constant {value}); } - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = MCase { tag = 5; @@ -615,11 +619,12 @@ module Encoding = struct select = (function | Manager (Set_deposits_limit _ as op) -> Some op | _ -> None); - proj = (function Set_deposits_limit key -> key); + proj = + (function[@coq_match_with_default] Set_deposits_limit key -> key); inj = (fun key -> Set_deposits_limit key); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = MCase { tag = tx_rollup_operation_origination_tag; @@ -628,7 +633,8 @@ module Encoding = struct select = (function | Manager (Tx_rollup_origination as op) -> Some op | _ -> None); - proj = (function Tx_rollup_origination -> ()); + proj = + (function[@coq_match_with_default] Tx_rollup_origination -> ()); inj = (fun () -> Tx_rollup_origination); } @@ -638,7 +644,7 @@ module Encoding = struct encoding which is in hexadecimal for JSON. *) conv Bytes.of_string Bytes.to_string bytes - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = MCase { tag = tx_rollup_operation_submit_batch_tag; @@ -652,7 +658,7 @@ module Encoding = struct (function | Manager (Tx_rollup_submit_batch _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> (tx_rollup, content, burn_limit)); inj = @@ -660,7 +666,7 @@ module Encoding = struct Tx_rollup_submit_batch {tx_rollup; content; burn_limit}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = MCase { tag = tx_rollup_operation_commit_tag; @@ -673,14 +679,14 @@ module Encoding = struct (function | Manager (Tx_rollup_commit _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment)); inj = (fun (tx_rollup, commitment) -> Tx_rollup_commit {tx_rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = MCase { tag = tx_rollup_operation_return_bond_tag; @@ -689,11 +695,13 @@ module Encoding = struct select = (function | Manager (Tx_rollup_return_bond _ as op) -> Some op | _ -> None); - proj = (function Tx_rollup_return_bond {tx_rollup} -> tx_rollup); + proj = + (function[@coq_match_with_default] + | Tx_rollup_return_bond {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_return_bond {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = MCase { tag = tx_rollup_operation_finalize_commitment_tag; @@ -704,11 +712,12 @@ module Encoding = struct | Manager (Tx_rollup_finalize_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_finalize_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = MCase { tag = tx_rollup_operation_remove_commitment_tag; @@ -719,11 +728,12 @@ module Encoding = struct | Manager (Tx_rollup_remove_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_remove_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = MCase { tag = tx_rollup_operation_rejection_tag; @@ -752,7 +762,7 @@ module Encoding = struct (function | Manager (Tx_rollup_rejection _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_rejection { tx_rollup; @@ -802,7 +812,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = MCase { tag = tx_rollup_operation_dispatch_tickets_tag; @@ -824,7 +834,7 @@ module Encoding = struct | Manager (Tx_rollup_dispatch_tickets _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_dispatch_tickets { tx_rollup; @@ -858,7 +868,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = MCase { tag = transfer_ticket_tag; @@ -875,7 +885,7 @@ module Encoding = struct (function | Manager (Transfer_ticket _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} -> (contents, ty, ticketer, amount, destination, entrypoint)); @@ -885,7 +895,7 @@ module Encoding = struct {contents; ty; ticketer; amount; destination; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = MCase { tag = sc_rollup_operation_origination_tag; @@ -898,13 +908,13 @@ module Encoding = struct (function | Manager (Sc_rollup_originate _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_originate {kind; boot_sector} -> (kind, boot_sector)); inj = (fun (kind, boot_sector) -> Sc_rollup_originate {kind; boot_sector}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = MCase { tag = sc_rollup_operation_add_message_tag; @@ -917,14 +927,14 @@ module Encoding = struct (function | Manager (Sc_rollup_add_messages _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_add_messages {rollup; messages} -> (rollup, messages)); inj = (fun (rollup, messages) -> Sc_rollup_add_messages {rollup; messages}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = MCase { tag = sc_rollup_operation_cement_tag; @@ -937,13 +947,13 @@ module Encoding = struct (function | Manager (Sc_rollup_cement _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_cement {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = MCase { tag = sc_rollup_operation_publish_tag; @@ -956,7 +966,7 @@ module Encoding = struct (function | Manager (Sc_rollup_publish _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_publish {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_publish {rollup; commitment}); @@ -982,15 +992,21 @@ module Encoding = struct encoding = consensus_content_encoding; select = (function Contents (Preendorsement _ as op) -> Some op | _ -> None); - proj = (fun (Preendorsement preendorsement) -> preendorsement); + proj = + (fun [@coq_match_with_default] (Preendorsement preendorsement) -> + preendorsement); inj = (fun preendorsement -> Preendorsement preendorsement); } let preendorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let make = + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.preendorsement contents_list -> _ = function + let to_list : Kind.preendorsement contents_list -> _ = + function[@coq_match_with_default] | Single o -> o in let of_list : Kind.preendorsement contents -> _ = function @@ -1012,19 +1028,17 @@ module Encoding = struct @@ union [make preendorsement_case])) (varopt "signature" Signature.encoding))) - let endorsement_encoding = - obj4 - (req "slot" Slot_repr.encoding) - (req "level" Raw_level_repr.encoding) - (req "round" Round_repr.encoding) - (req "block_payload_hash" Block_payload_hash.encoding) - let endorsement_case = Case { tag = 21; name = "endorsement"; - encoding = endorsement_encoding; + encoding = + obj4 + (req "slot" Slot_repr.encoding) + (req "level" Raw_level_repr.encoding) + (req "round" Round_repr.encoding) + (req "block_payload_hash" Block_payload_hash.encoding); select = (function Contents (Endorsement _ as op) -> Some op | _ -> None); proj = @@ -1038,11 +1052,16 @@ module Encoding = struct Endorsement {slot; level; round; block_payload_hash}); } - let[@coq_axiom_with_reason "gadt"] endorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let endorsement_encoding = + let make = + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.endorsement contents_list -> _ = fun (Single o) -> o in + let to_list : Kind.endorsement contents_list -> _ = + fun [@coq_match_with_default] (Single o) -> o + in let of_list : Kind.endorsement contents -> _ = fun o -> Single o in def "inlined.endorsement" @@ conv @@ -1060,7 +1079,7 @@ module Encoding = struct @@ union [make endorsement_case])) (varopt "signature" Signature.encoding))) - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { tag = 1; @@ -1072,11 +1091,13 @@ module Encoding = struct select = (function | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None); - proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce)); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation {level; nonce}) -> + (level, nonce)); inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce}); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case : + let double_preendorsement_evidence_case : Kind.double_preendorsement_evidence case = Case { @@ -1090,12 +1111,14 @@ module Encoding = struct (function | Contents (Double_preendorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_preendorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_preendorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case : - Kind.double_endorsement_evidence case = + let double_endorsement_evidence_case : Kind.double_endorsement_evidence case = Case { tag = 2; @@ -1108,11 +1131,14 @@ module Encoding = struct (function | Contents (Double_endorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { tag = 3; @@ -1124,11 +1150,13 @@ module Encoding = struct select = (function | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2)); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence {bh1; bh2}) -> + (bh1, bh2)); inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2}); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { tag = 4; @@ -1141,13 +1169,14 @@ module Encoding = struct (function | Contents (Activate_account _ as op) -> Some op | _ -> None); proj = - (fun (Activate_account {id; activation_code}) -> + (fun [@coq_match_with_default] (Activate_account + {id; activation_code}) -> (id, activation_code)); inj = (fun (id, activation_code) -> Activate_account {id; activation_code}); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { tag = 5; @@ -1160,14 +1189,14 @@ module Encoding = struct select = (function Contents (Proposals _ as op) -> Some op | _ -> None); proj = - (fun (Proposals {source; period; proposals}) -> + (fun [@coq_match_with_default] (Proposals {source; period; proposals}) -> (source, period, proposals)); inj = (fun (source, period, proposals) -> Proposals {source; period; proposals}); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { tag = 6; @@ -1180,7 +1209,7 @@ module Encoding = struct (req "ballot" Vote_repr.ballot_encoding); select = (function Contents (Ballot _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Ballot {source; period; proposal; ballot} -> (source, period, proposal, ballot)); inj = @@ -1219,8 +1248,9 @@ module Encoding = struct Manager_operation {source; fee; counter; gas_limit; storage_limit; operation} - let[@coq_axiom_with_reason "gadt"] make_manager_case tag (type kind) - (Manager_operations.MCase mcase : kind Manager_operations.case) = + let make_manager_case tag (type kind) = + fun [@coq_grab_existentials] (Manager_operations.MCase mcase : + kind Manager_operations.case) -> Case { tag; @@ -1234,7 +1264,7 @@ module Encoding = struct | Some operation -> Some (Manager_operation {op with operation})) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Manager_operation {operation; _} as op -> (extract op, mcase.proj operation)); inj = (fun (op, contents) -> rebuild op (mcase.inj contents)); @@ -1322,13 +1352,16 @@ module Encoding = struct Manager_operations.sc_rollup_publish_case let contents_encoding = - let make (Case {tag; name; encoding; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Contents (inj x)) + let make case_description = + match[@coq_grab_existentials] case_description with + | Case {tag; name; encoding; select; proj; inj} -> + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Contents (inj x)) in def "operation.alpha.contents" @@ union @@ -1417,7 +1450,7 @@ let raw ({shell; protocol_data} : _ operation) = let acceptable_passes (op : packed_operation) = let (Operation_data protocol_data) = op.protocol_data in - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Failing_noop _) -> [] | Single (Preendorsement _) -> [0] | Single (Endorsement _) -> [0] @@ -1488,7 +1521,7 @@ let check_signature (type kind) key chain_id match protocol_data.signature with | None -> error Missing_signature | Some signature -> ( - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Preendorsement _) as contents -> check ~watermark:(to_watermark (Preendorsement chain_id)) diff --git a/src/proto_013_PtJakart/lib_protocol/operation_repr.mli b/src/proto_013_PtJakart/lib_protocol/operation_repr.mli index de7e706f444b3..e90801b6314f7 100644 --- a/src/proto_013_PtJakart/lib_protocol/operation_repr.mli +++ b/src/proto_013_PtJakart/lib_protocol/operation_repr.mli @@ -151,12 +151,13 @@ module Kind : sig | Sc_rollup_publish_manager_kind : sc_rollup_publish manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot_repr.t; @@ -173,13 +174,13 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t +module Consensus_watermark : sig + type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t +end -val to_watermark : consensus_watermark -> Signature.watermark +val to_watermark : Consensus_watermark.t -> Signature.watermark -val of_watermark : Signature.watermark -> consensus_watermark option +val of_watermark : Signature.watermark -> Consensus_watermark.t option type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} @@ -198,118 +199,9 @@ type origination = { credit : Tez_repr.tez; } -(** An [operation] contains the operation header information in [shell] - and all data related to the operation itself in [protocol_data]. *) -type 'kind operation = { - shell : Operation.shell_header; - protocol_data : 'kind protocol_data; -} - -(** A [protocol_data] wraps together a signature for the operation and - the contents of the operation itself. *) -and 'kind protocol_data = { - contents : 'kind contents_list; - signature : Signature.t option; -} - -(** A [contents_list] is a list of contents, the GADT guarantees two - invariants: - - the list is not empty, and - - if the list has several elements then it only contains manager - operations. *) -and _ contents_list = - | Single : 'kind contents -> 'kind contents_list - | Cons : - 'kind Kind.manager contents * 'rest Kind.manager contents_list - -> ('kind * 'rest) Kind.manager contents_list - -(** A value of type [contents] an operation related to whether - consensus, governance or contract management. *) -and _ contents = - (* Preendorsement: About consensus, preendorsement of a block held by a - validator (specific to Tenderbake). *) - | Preendorsement : consensus_content -> Kind.preendorsement contents - (* Endorsement: About consensus, endorsement of a block held by a - validator. *) - | Endorsement : consensus_content -> Kind.endorsement contents - (* Seed_nonce_revelation: Nonces are created by bakers and are - combined to create pseudo-random seeds. Bakers are urged to reveal their - nonces after a given number of cycles to keep their block rewards - from being forfeited. *) - | Seed_nonce_revelation : { - level : Raw_level_repr.t; - nonce : Seed_repr.nonce; - } - -> Kind.seed_nonce_revelation contents - (* Double_preendorsement_evidence: Double-preendorsement is a - kind of malicious attack where a byzantine attempts to fork - the chain by preendorsing blocks with different - contents (at the same level and same round) - twice. This behavior may be reported and the byzantine will have - its security deposit forfeited. *) - | Double_preendorsement_evidence : { - op1 : Kind.preendorsement operation; - op2 : Kind.preendorsement operation; - } - -> Kind.double_preendorsement_evidence contents - (* Double_endorsement_evidence: Similar to double-preendorsement but - for endorsements. *) - | Double_endorsement_evidence : { - op1 : Kind.endorsement operation; - op2 : Kind.endorsement operation; - } - -> Kind.double_endorsement_evidence contents - (* Double_baking_evidence: Similarly to double-endorsement but the - byzantine attempts to fork by signing two different blocks at the - same level. *) - | Double_baking_evidence : { - bh1 : Block_header_repr.t; - bh2 : Block_header_repr.t; - } - -> Kind.double_baking_evidence contents - (* Activate_account: Account activation allows to register a public - key hash on the blockchain. *) - | Activate_account : { - id : Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - } - -> Kind.activate_account contents - (* Proposals: A candidate protocol can be proposed for voting. *) - | Proposals : { - source : Signature.Public_key_hash.t; - period : int32; - proposals : Protocol_hash.t list; - } - -> Kind.proposals contents - (* Ballot: The validators of the chain will then vote on proposals. *) - | Ballot : { - source : Signature.Public_key_hash.t; - period : int32; - proposal : Protocol_hash.t; - ballot : Vote_repr.ballot; - } - -> Kind.ballot contents - (* Failing_noop: An operation never considered by the state machine - and which will always fail at [apply]. This allows end-users to - sign arbitrary messages which have no computational semantics. *) - | Failing_noop : string -> Kind.failing_noop contents - (* Manager_operation: Operations, emitted and signed by - a (revealed) implicit account, that describe management and - interactions between contracts (whether implicit or - smart). *) - | Manager_operation : { - source : Signature.Public_key_hash.t; - fee : Tez_repr.tez; - counter : counter; - operation : 'kind manager_operation; - gas_limit : Gas_limit_repr.Arith.integral; - storage_limit : Z.t; - } - -> 'kind Kind.manager contents - (** A [manager_operation] describes management and interactions between contracts (whether implicit or smart). *) -and _ manager_operation = +type _ manager_operation = (* [Reveal] for the revelation of a public key, a one-time prerequisite to any signed operation, in order to be able to check the sender’s signature. *) @@ -448,7 +340,116 @@ and _ manager_operation = each manager operation declares a value for the counter. When a manager operation is applied, the value of the counter of its manager is checked and incremented. *) -and counter = Z.t +type counter = Z.t + +(** An [operation] contains the operation header information in [shell] + and all data related to the operation itself in [protocol_data]. *) +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +(** A [protocol_data] wraps together a signature for the operation and + the contents of the operation itself. *) +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +(** A [contents_list] is a list of contents, the GADT guarantees two + invariants: + - the list is not empty, and + - if the list has several elements then it only contains manager + operations. *) +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +(** A value of type [contents] an operation related to whether + consensus, governance or contract management. *) +and _ contents = + (* Preendorsement: About consensus, preendorsement of a block held by a + validator (specific to Tenderbake). *) + | Preendorsement : consensus_content -> Kind.preendorsement contents + (* Endorsement: About consensus, endorsement of a block held by a + validator. *) + | Endorsement : consensus_content -> Kind.endorsement contents + (* Seed_nonce_revelation: Nonces are created by bakers and are + combined to create pseudo-random seeds. Bakers are urged to reveal their + nonces after a given number of cycles to keep their block rewards + from being forfeited. *) + | Seed_nonce_revelation : { + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents + (* Double_preendorsement_evidence: Double-preendorsement is a + kind of malicious attack where a byzantine attempts to fork + the chain by preendorsing blocks with different + contents (at the same level and same round) + twice. This behavior may be reported and the byzantine will have + its security deposit forfeited. *) + | Double_preendorsement_evidence : { + op1 : Kind.preendorsement operation; + op2 : Kind.preendorsement operation; + } + -> Kind.double_preendorsement_evidence contents + (* Double_endorsement_evidence: Similar to double-preendorsement but + for endorsements. *) + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + (* Double_baking_evidence: Similarly to double-endorsement but the + byzantine attempts to fork by signing two different blocks at the + same level. *) + | Double_baking_evidence : { + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents + (* Activate_account: Account activation allows to register a public + key hash on the blockchain. *) + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + (* Proposals: A candidate protocol can be proposed for voting. *) + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + (* Ballot: The validators of the chain will then vote on proposals. *) + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents + (* Failing_noop: An operation never considered by the state machine + and which will always fail at [apply]. This allows end-users to + sign arbitrary messages which have no computational semantics. *) + | Failing_noop : string -> Kind.failing_noop contents + (* Manager_operation: Operations, emitted and signed by + a (revealed) implicit account, that describe management and + interactions between contracts (whether implicit or + smart). *) + | Manager_operation : { + source : Signature.Public_key_hash.t; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas_limit_repr.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation diff --git a/src/proto_013_PtJakart/lib_protocol/raw_context.ml b/src/proto_013_PtJakart/lib_protocol/raw_context.ml index 025a903e1ad53..767a79155e0c0 100644 --- a/src/proto_013_PtJakart/lib_protocol/raw_context.ml +++ b/src/proto_013_PtJakart/lib_protocol/raw_context.ml @@ -625,7 +625,7 @@ let storage_error err = error (Storage_error err) let version_key = ["version"] (* This value is set by the snapshot_alpha.sh script, don't change it. *) -let version_value = "jakarta_013" +let version_value = "alpha_current" let version = "v1" @@ -1067,8 +1067,6 @@ let fold ?depth ctxt k ~order ~init ~f = let config ctxt = Context.config (context ctxt) -module Proof = Context.Proof - module Tree : Raw_context_intf.TREE with type t := t @@ -1405,3 +1403,71 @@ module Sc_rollup_in_memory_inbox = struct let back = {ctxt.back with sc_rollup_current_messages} in {ctxt with back} end + +(** Explicit module to present this file as a record in Coq and reduce the size + of the generated Coq code. *) +module M : T with type t = root = struct + type t = root + + type error += Block_quota_exceeded = Block_quota_exceeded + + type error += Operation_quota_exceeded = Operation_quota_exceeded + + let mem = mem + + let mem_tree = mem_tree + + let get = get + + let get_tree = get_tree + + let find = find + + let find_tree = find_tree + + let list = list + + let init = init + + let init_tree = init_tree + + let update = update + + let update_tree = update_tree + + let add = add + + let add_tree = add_tree + + let remove = remove + + let remove_existing = remove_existing + + let remove_existing_tree = remove_existing_tree + + let add_or_remove = add_or_remove + + let add_or_remove_tree = add_or_remove_tree + + let fold = fold + + let config = config + + module Tree = Tree + + let verify_tree_proof = verify_tree_proof + + let verify_stream_proof = verify_stream_proof + + let equal_config = equal_config + + let project : t -> root = project + + let absolute_key : t -> key -> key = absolute_key + + let consume_gas = consume_gas + + let check_enough_gas = check_enough_gas + + let description : t Storage_description.t = description +end diff --git a/src/proto_013_PtJakart/lib_protocol/raw_context.mli b/src/proto_013_PtJakart/lib_protocol/raw_context.mli index c7e306e2b3ec4..21304c4d052fb 100644 --- a/src/proto_013_PtJakart/lib_protocol/raw_context.mli +++ b/src/proto_013_PtJakart/lib_protocol/raw_context.mli @@ -370,3 +370,5 @@ module Sc_rollup_in_memory_inbox : sig val set_current_messages : t -> Sc_rollup_repr.t -> Context.tree -> t end + +module M : T with type t = root diff --git a/src/proto_013_PtJakart/lib_protocol/raw_context_intf.ml b/src/proto_013_PtJakart/lib_protocol/raw_context_intf.ml index d6ef0becd0e5e..8840c5d9c8b37 100644 --- a/src/proto_013_PtJakart/lib_protocol/raw_context_intf.ml +++ b/src/proto_013_PtJakart/lib_protocol/raw_context_intf.ml @@ -28,9 +28,6 @@ as-is for direct context accesses, and used in {!Storage_functors} to provide restricted views to the context. *) -(** The tree depth of a fold. See the [fold] function for more information. *) -type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] - (** The type for context configuration. If two trees or stores have the same configuration, they will generate the same context hash. *) type config = Context.config @@ -173,7 +170,7 @@ module type VIEW = sig lexicographic order of their keys. For large nodes, it is memory-consuming, use [`Undefined] for a more memory efficient [fold]. *) val fold : - ?depth:depth -> + ?depth:Context.depth -> t -> key -> order:[`Sorted | `Undefined] -> @@ -187,10 +184,6 @@ module type VIEW = sig val config : t -> config end -module Kind = struct - type t = [`Value | `Tree] -end - module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the context, with lazy reads and delayed writes. The trees are Merkle @@ -219,7 +212,7 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> Kind.t + val kind : tree -> Context.Kind.t (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] is a leaf tree and [None] otherwise. It is equivalent to [find t @@ -240,203 +233,6 @@ module type TREE = sig val clear : ?depth:int -> tree -> unit end -module type PROOF = sig - (** Proofs are compact representations of trees which can be shared - between peers. - - This is expected to be used as follows: - - - A first peer runs a function [f] over a tree [t]. While performing - this computation, it records: the hash of [t] (called [before] - below), the hash of [f t] (called [after] below) and a subset of [t] - which is needed to replay [f] without any access to the first peer's - storage. Once done, all these informations are packed into a proof of - type [t] that is sent to the second peer. - - - The second peer generates an initial tree [t'] from [p] and computes - [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before] - and [after]. If they match, they know that the result state [f t'] is a - valid context state, without having to have access to the full storage - of the first peer. *) - - (** The type for file and directory names. *) - type step = string - - (** The type for values. *) - type value = bytes - - (** The type of indices for inodes' children. *) - type index = int - - (** The type for hashes. *) - type hash = Context_hash.t - - (** The type for (internal) inode proofs. - - These proofs encode large directories into a tree-like structure. This - reflects irmin-pack's way of representing nodes and computing - hashes (tree-like representations for nodes scales better than flat - representations). - - [length] is the total number of entries in the children of the inode. - It's the size of the "flattened" version of that inode. [length] can be - used to prove the correctness of operations such [Tree.length] and - [Tree.list ~offset ~length] in an efficient way. - - In proofs with [version.is_binary = false], an inode at depth 0 has a - [length] of at least [257]. Below that threshold a [Node] tag is used in - [tree]. That threshold is [3] when [version.is_binary = true]. - - [proofs] contains the children proofs. It is a sparse list of ['a] values. - These values are associated to their index in the list, and the list is - kept sorted in increasing order of indices. ['a] can be a concrete proof - or a hash of that proof. - - In proofs with [version.is_binary = true], inodes have at most 2 proofs - (indexed 0 or 1). - - In proofs with [version.is_binary = false], inodes have at most 32 proofs - (indexed from 0 to 31). *) - type 'a inode = {length : int; proofs : (index * 'a) list} - - (** The type for inode extenders. - - An extender is a compact representation of a sequence of [inode] which - contain only one child. As for inodes, The ['a] parameter can be a - concrete proof or a hash of that proof. - - If an inode proof contains singleton children [i_0, ..., i_n] such as: - [{length=l; proofs = [ (i_0, {proofs = ... { proofs = [ (i_n, p) ] }})]}], - then it is compressed into the inode extender - [{length=l; segment = [i_0;..;i_n]; proof=p}] sharing the same lenght [l] - and final proof [p]. *) - type 'a inode_extender = {length : int; segment : index list; proof : 'a} - - (** The type for compressed and partial Merkle tree proofs. - - Tree proofs do not provide any guarantee with the ordering of - computations. For instance, if two effects commute, they won't be - distinguishable by this kind of proofs. - - [Value v] proves that a value [v] exists in the store. - - [Blinded_value h] proves a value with hash [h] exists in the store. - - [Node ls] proves that a a "flat" node containing the list of files [ls] - exists in the store. - - In proofs with [version.is_binary = true], the length of [ls] is at most - 2. - - In proofs with [version.is_binary = false], the length of [ls] is at most - 256. - - [Blinded_node h] proves that a node with hash [h] exists in the store. - - [Inode i] proves that an inode [i] exists in the store. - - [Extender e] proves that an inode extender [e] exist in the store. *) - type tree = - | Value of value - | Blinded_value of hash - | Node of (step * tree) list - | Blinded_node of hash - | Inode of inode_tree inode - | Extender of inode_tree inode_extender - - (** The type for inode trees. It is a subset of [tree], limited to nodes. - - [Blinded_inode h] proves that an inode with hash [h] exists in the store. - - [Inode_values ls] is simliar to trees' [Node]. - - [Inode_tree i] is similar to tree's [Inode]. - - [Inode_extender e] is similar to trees' [Extender]. *) - and inode_tree = - | Blinded_inode of hash - | Inode_values of (step * tree) list - | Inode_tree of inode_tree inode - | Inode_extender of inode_tree inode_extender - - (** The type for kinded hashes. *) - type kinded_hash = [`Value of hash | `Node of hash] - - module Stream : sig - (** Stream proofs represent an explicit traversal of a Merle tree proof. - Every element (a node, a value, or a shallow pointer) met is first - "compressed" by shallowing its children and then recorded in the proof. - - As stream proofs directly encode the recursive construction of the - Merkle root hash is slightly simpler to implement: verifier simply - need to hash the compressed elements lazily, without any memory or - choice. - - Moreover, the minimality of stream proofs is trivial to check. - Once the computation has consumed the compressed elements required, - it is sufficient to check that no more compressed elements remain - in the proof. - - However, as the compressed elements contain all the hashes of their - shallow children, the size of stream proofs is larger - (at least double in size in practice) than tree proofs, which only - contains the hash for intermediate shallow pointers. *) - - (** The type for elements of stream proofs. - - [Value v] is a proof that the next element read in the store is the - value [v]. - - [Node n] is a proof that the next element read in the store is the - node [n]. - - [Inode i] is a proof that the next element read in the store is the - inode [i]. - - [Inode_extender e] is a proof that the next element read in the store - is the node extender [e]. *) - type elt = - | Value of value - | Node of (step * kinded_hash) list - | Inode of hash inode - | Inode_extender of hash inode_extender - - (** The type for stream proofs. - - The sequance [e_1 ... e_n] proves that the [e_1], ..., [e_n] are - read in the store in sequence. *) - type t = elt Seq.t - end - - type stream = Stream.t - - (** The type for proofs of kind ['a]. - - A proof [p] proves that the state advanced from [before p] to - [after p]. [state p]'s hash is [before p], and [state p] contains - the minimal information for the computation to reach [after p]. - - [version p] is the proof version, it packs several informations. - - [is_stream] discriminates between the stream proofs and the tree proofs. - - [is_binary] discriminates between proofs emitted from - [Tezos_context(_memory).Context_binary] and - [Tezos_context(_memory).Context]. - - It will also help discriminate between the data encoding techniques used. - - The version is meant to be decoded and encoded using the - {!Tezos_context_helpers.Context.decode_proof_version} and - {!Tezos_context_helpers.Context.encode_proof_version}. *) - type 'a t = { - version : int; - before : kinded_hash; - after : kinded_hash; - state : 'a; - } -end - module type T = sig (** The type for root contexts. *) type root @@ -450,8 +246,6 @@ module type T = sig and type value := value and type tree := tree - module Proof : PROOF - (** [verify p f] runs [f] in checking mode. [f] is a function that takes a tree as input and returns a new version of the tree and a result. [p] is a proof, that is a minimal representation of the tree that contains what [f] @@ -503,7 +297,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, *in some order*. *) - type tree_proof := Proof.tree Proof.t + type tree_proof := Context.Proof.tree Context.Proof.t (** [verify_tree_proof] is the verifier of tree proofs. *) val verify_tree_proof : (tree_proof, 'a) verifier @@ -512,7 +306,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, in the exact same order. *) - type stream_proof := Proof.stream Proof.t + type stream_proof := Context.Proof.stream Context.Proof.t (** [verify_stream] is the verifier of stream proofs. *) val verify_stream_proof : (stream_proof, 'a) verifier diff --git a/src/proto_013_PtJakart/lib_protocol/round_repr.ml b/src/proto_013_PtJakart/lib_protocol/round_repr.ml index 8a60fa3176841..8a0f59d8ab967 100644 --- a/src/proto_013_PtJakart/lib_protocol/round_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/round_repr.ml @@ -107,7 +107,7 @@ let encoding = (fun i -> i) (fun i -> match of_int32 i with - | Ok _ as res -> res + | Ok round -> Ok round | Error _ -> Error "Round_repr.encoding: negative round") Data_encoding.int32 diff --git a/src/proto_013_PtJakart/lib_protocol/sampler.ml b/src/proto_013_PtJakart/lib_protocol/sampler.ml index b390b6dcf54be..6f42b1da9ad1b 100644 --- a/src/proto_013_PtJakart/lib_protocol/sampler.ml +++ b/src/proto_013_PtJakart/lib_protocol/sampler.ml @@ -74,7 +74,7 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct alias : int FallbackArray.t; } - let rec init_loop total p alias small large = + let[@coq_struct "small"] rec init_loop total p alias small large = match (small, large) with | ([], _) -> List.iter (fun (_, i) -> FallbackArray.set p i total) large | (_, []) -> diff --git a/src/proto_013_PtJakart/lib_protocol/sapling_repr.ml b/src/proto_013_PtJakart/lib_protocol/sapling_repr.ml index 0b472fea5c28f..414854256b377 100644 --- a/src/proto_013_PtJakart/lib_protocol/sapling_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/sapling_repr.ml @@ -25,6 +25,8 @@ type transaction = Sapling.UTXO.transaction +type legacy_transaction = Sapling.UTXO.Legacy.transaction + let transaction_encoding = Sapling.UTXO.transaction_encoding (* The two data structures in the state are all ordered by position, a diff diff --git a/src/proto_013_PtJakart/lib_protocol/sapling_storage.ml b/src/proto_013_PtJakart/lib_protocol/sapling_storage.ml index 167f75f1f913b..600c870ef43c3 100644 --- a/src/proto_013_PtJakart/lib_protocol/sapling_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/sapling_storage.ml @@ -240,7 +240,7 @@ module Ciphertexts = struct let add ctx id c pos = Storage.Sapling.Ciphertexts.init (ctx, id) pos c let get_from ctx id offset = - let rec aux (ctx, acc) pos = + let[@coq_struct "function_parameter"] rec aux (ctx, acc) pos = Storage.Sapling.Ciphertexts.find (ctx, id) pos >>=? fun (ctx, c) -> match c with | None -> return (ctx, List.rev acc) @@ -319,7 +319,7 @@ module Roots = struct let mem ctx id root = Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun start_pos -> - let rec aux pos = + let[@coq_struct "pos"] rec aux pos = Storage.Sapling.Roots.get (ctx, id) pos >>=? fun hash -> if Compare.Int.(Sapling.Hash.compare hash root = 0) then return true else diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_arith.ml b/src/proto_013_PtJakart/lib_protocol/sc_rollup_arith.ml index 67d40d068be53..fc283670892e4 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_arith.ml @@ -233,7 +233,7 @@ module Make (Context : P) : open Monad open Monad.Syntax - module MakeVar (P : sig + module type P_MakeVar = sig type t val name : string @@ -243,8 +243,21 @@ module Make (Context : P) : val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - end) = - struct + end + + module type S_MakeVar = sig + type t + + val create : unit Monad.t + + val get : t Monad.t + + val set : t -> unit Monad.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module MakeVar (P : P_MakeVar) : S_MakeVar with type t := P.t = struct let key = [P.name] let create = set_value key P.encoding P.initial @@ -265,14 +278,29 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end - module MakeDeque (P : sig + module type P_MakeDeque = sig type t val name : string val encoding : t Data_encoding.t - end) = - struct + end + + module type S_MakeDeque = sig + type t + + val push : t -> unit Monad.t + + val pop : t option Monad.t + + val inject : t -> unit Monad.t + + val to_list : t list Monad.t + + val clear : unit Monad.t + end + + module MakeDeque (P : P_MakeDeque) : S_MakeDeque with type t := P.t = struct (* A stateful deque. @@ -330,7 +358,7 @@ module Make (Context : P) : let open Monad.Syntax in let* head_idx = get_head in let* end_idx = get_end in - let rec aux l idx = + let[@coq_struct "idx"] rec aux l idx = if Z.(lt idx head_idx) then return l else let* v = find_value (idx_key idx) P.encoding in @@ -343,11 +371,13 @@ module Make (Context : P) : let clear = remove [P.name] end - module CurrentTick = MakeVar (struct + module Tick_with_name = struct include Tick let name = "tick" - end) + end + + module CurrentTick = MakeVar (Tick_with_name) module Stack = MakeDeque (struct type t = int diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_game.ml b/src/proto_013_PtJakart/lib_protocol/sc_rollup_game.ml index 8ce62325ae756..5c758db8353e9 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_game.ml +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_game.ml @@ -39,7 +39,7 @@ module Make (PVM : Sc_rollup_PVM_sem.S) = struct section_stop_at : tick; } - and dissection = section Sc_rollup_tick_repr.Map.t + type dissection = section Sc_rollup_tick_repr.Map.t let section_encoding = let open Data_encoding in diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.ml index be457b5de8bba..abb6421913aa4 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.ml @@ -330,11 +330,13 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end -module MakeHashingScheme (Tree : TREE) : - MerkelizedOperations with type tree = Tree.tree = struct - module Tree = Tree +module MakeHashingScheme (P : TREE) : + MerkelizedOperations with type tree = P.tree = struct + module Tree = P type tree = Tree.tree @@ -474,7 +476,7 @@ module MakeHashingScheme (Tree : TREE) : in (history, inbox) in - let rec aux (history, inbox) = + let[@coq_struct "function_parameter"] rec aux (history, inbox) = if Raw_level_repr.(inbox.level = target_level) then (history, inbox) else aux (archive_level history inbox) in @@ -552,7 +554,15 @@ end include ( MakeHashingScheme (struct - include Context.Tree + let find = Context.Tree.find + + let find_tree = Context.Tree.find_tree + + let add = Context.Tree.add + + let is_empty = Context.Tree.is_empty + + let hash = Context.Tree.hash type t = Context.t @@ -561,5 +571,7 @@ include ( type value = bytes type key = string list + + let __infer_t (_ : t) = () end) : MerkelizedOperations with type tree = Context.tree) diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.mli b/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.mli index 705a988ea575a..f22d62a822fdd 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_inbox_repr.mli @@ -271,6 +271,8 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end (** diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.ml b/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.ml index 82174159d3208..f26031dbc110b 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.ml @@ -167,9 +167,11 @@ let () = (fun loc -> Invalid_sc_rollup_address loc) let of_b58check s = + let error () = Error (Format.sprintf "Invalid_sc_rollup_address %s" s) in match Base58.decode s with - | Some (Address.Data hash) -> ok hash - | _ -> Error (Format.sprintf "Invalid_sc_rollup_address %s" s) + | Some data -> ( + match data with Address.Data hash -> ok hash | _ -> error ()) + | _ -> error () let pp = Address.pp @@ -217,7 +219,8 @@ module Index = struct let compare = Address.compare end -module Commitment_hash_index = struct +module Commitment_hash_index : + Storage_description.INDEX with type t = Commitment_hash.t = struct include Commitment_hash end diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.mli b/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.mli index 72807ac004a54..4e7c87c53fe7f 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_repr.mli @@ -56,9 +56,9 @@ module Internal_for_tests : sig val originated_sc_rollup : Origination_nonce.t -> Address.t end -module Commitment_hash : S.HASH +module Commitment_hash : S.HASH [@@coq_plain_module] -module State_hash : S.HASH +module State_hash : S.HASH [@@coq_plain_module] (** Number of messages consumed by a single commitment. This represents a claim about the shape of the Inbox, which can be disputed as part of a commitment @@ -149,3 +149,4 @@ module Kind : sig val pp : Format.formatter -> t -> unit end +[@@coq_plain_module] diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_storage.ml b/src/proto_013_PtJakart/lib_protocol/sc_rollup_storage.ml index 6772013fe2810..b79466da00fdd 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_storage.ml @@ -217,8 +217,6 @@ module Lwt_tzresult_syntax = struct end module Store = Storage.Sc_rollup -module Commitment = Sc_rollup_repr.Commitment -module Commitment_hash = Sc_rollup_repr.Commitment_hash let originate ctxt ~kind ~boot_sector = Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) -> @@ -233,7 +231,10 @@ let originate ctxt ~kind ~boot_sector = Storage.Sc_rollup.Boot_sector.add ctxt address boot_sector >>= fun ctxt -> let inbox = Sc_rollup_inbox_repr.empty address level.level in Storage.Sc_rollup.Inbox.init ctxt address inbox >>=? fun (ctxt, size_diff) -> - Store.Last_cemented_commitment.init ctxt address Commitment_hash.zero + Store.Last_cemented_commitment.init + ctxt + address + Sc_rollup_repr.Commitment_hash.zero >>=? fun (ctxt, lcc_size_diff) -> Store.Staker_count.init ctxt address 0l >>=? fun (ctxt, stakers_size_diff) -> let addresses_size = 2 * Sc_rollup_repr.Address.size in @@ -372,7 +373,7 @@ let set_commitment_added ctxt rollup node new_value = let deallocate ctxt rollup node = let open Lwt_tzresult_syntax in - if Commitment_hash.(node = zero) then return ctxt + if Sc_rollup_repr.Commitment_hash.(node = zero) then return ctxt else let* (ctxt, _size_freed) = Store.Commitments.remove_existing (ctxt, rollup) node @@ -430,7 +431,7 @@ let withdraw_stake ctxt rollup staker = match res with | None -> fail Sc_rollup_not_staked | Some staked_on_commitment -> - if Commitment_hash.(staked_on_commitment = lcc) then + if Sc_rollup_repr.Commitment_hash.(staked_on_commitment = lcc) then (* TODO: https://gitlab.com/tezos/tezos/-/issues/2449 We should refund stake here. *) @@ -456,14 +457,14 @@ let sc_rollup_commitment_storage_size_in_bytes = 84 let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = let open Lwt_tzresult_syntax in let* (ctxt, min_level) = - if Commitment_hash.(lcc = zero) then + if Sc_rollup_repr.Commitment_hash.(lcc = zero) then let* level = Store.Initial_level.get ctxt rollup in return (ctxt, level) else let* (lcc, ctxt) = get_commitment_internal ctxt rollup lcc in - return (ctxt, Commitment.(lcc.inbox_level)) + return (ctxt, Sc_rollup_repr.Commitment.(lcc.inbox_level)) in - let max_level = Commitment.(commitment.inbox_level) in + let max_level = Sc_rollup_repr.Commitment.(commitment.inbox_level) in if Compare.Int32.( sc_rollup_max_lookahead < Raw_level_repr.diff max_level min_level) @@ -475,16 +476,16 @@ let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = *) let assert_commitment_frequency ctxt rollup commitment = let open Lwt_tzresult_syntax in - let pred = Commitment.(commitment.predecessor) in + let pred = Sc_rollup_repr.Commitment.(commitment.predecessor) in let* (ctxt, pred_level) = - if Commitment_hash.(pred = zero) then + if Sc_rollup_repr.Commitment_hash.(pred = zero) then let* level = Store.Initial_level.get ctxt rollup in return (ctxt, level) else let* (pred, ctxt) = get_commitment_internal ctxt rollup commitment.predecessor in - return (ctxt, Commitment.(pred.inbox_level)) + return (ctxt, Sc_rollup_repr.Commitment.(pred.inbox_level)) in (* We want to check the following inequalities on [commitment.inbox_level], [commitment.predecessor.inbox_level] and the constant [sc_rollup_commitment_frequency]. @@ -526,14 +527,14 @@ let refine_stake ctxt rollup staker commitment = let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in let* (staked_on, ctxt) = find_staker ctxt rollup staker in let* ctxt = assert_refine_conditions_met ctxt rollup lcc commitment in - let new_hash = Commitment.hash commitment in + let new_hash = Sc_rollup_repr.Commitment.hash commitment in (* TODO: https://gitlab.com/tezos/tezos/-/issues/2559 Add a test checking that L2 nodes can catch up after going offline. *) - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = (* WARNING: Do NOT reorder this sequence of ifs. we must check for staked_on before LCC, since refining from the LCC to another commit is a valid operation. *) - if Commitment_hash.(node = staked_on) then ( + if Sc_rollup_repr.Commitment_hash.(node = staked_on) then ( (* Previously staked commit found: Insert new commitment if not existing *) let* (ctxt, commitment_size_diff, _was_bound) = @@ -560,7 +561,7 @@ let refine_stake ctxt rollup staker commitment = size_diff = 0 || size_diff = sc_rollup_commitment_storage_size_in_bytes)) ; return (new_hash, ctxt) (* See WARNING above. *)) - else if Commitment_hash.(node = lcc) then + else if Sc_rollup_repr.Commitment_hash.(node = lcc) then (* We reached the LCC, but [staker] is not staked directly on it. Thus, we backtracked. Note that everyone is staked indirectly on the LCC. *) @@ -570,7 +571,7 @@ let refine_stake ctxt rollup staker commitment = let* (_size, ctxt) = increase_commitment_stake_count ctxt rollup node in (go [@ocaml.tailcall]) pred ctxt in - go Commitment.(commitment.predecessor) ctxt + go Sc_rollup_repr.Commitment.(commitment.predecessor) ctxt let publish_commitment ctxt rollup staker commitment = let open Lwt_tzresult_syntax in @@ -599,8 +600,9 @@ let cement_commitment ctxt rollup new_lcc = let* (ctxt, new_lcc_added) = Store.Commitment_added.get (ctxt, rollup) new_lcc in - if Commitment_hash.(new_lcc_commitment.predecessor <> old_lcc) then - fail Sc_rollup_parent_not_lcc + if + Sc_rollup_repr.Commitment_hash.(new_lcc_commitment.predecessor <> old_lcc) + then fail Sc_rollup_parent_not_lcc else let* (new_lcc_stake_count, ctxt) = get_commitment_stake_count ctxt rollup new_lcc @@ -629,15 +631,18 @@ let cement_commitment ctxt rollup new_lcc = @@ Sc_rollup_repr.Number_of_messages.to_int32 new_lcc_commitment.number_of_messages) -type conflict_point = Commitment_hash.t * Commitment_hash.t +type conflict_point = + Sc_rollup_repr.Commitment_hash.t * Sc_rollup_repr.Commitment_hash.t (** [goto_inbox_level ctxt rollup inbox_level commit] Follows the predecessors of [commit] until it arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *) let goto_inbox_level ctxt rollup inbox_level commit = let open Lwt_tzresult_syntax in - let rec go ctxt commit = + let[@coq_struct "commit"] rec go ctxt commit = let* (info, ctxt) = get_commitment_internal ctxt rollup commit in - if Raw_level_repr.(info.Commitment.inbox_level <= inbox_level) then ( + if + Raw_level_repr.(info.Sc_rollup_repr.Commitment.inbox_level <= inbox_level) + then ( (* Assert that we're exactly at that level. If this isn't the case, we're most likely in a situation where inbox levels are inconsistent. *) assert (Raw_level_repr.(info.inbox_level = inbox_level)) ; @@ -655,7 +660,7 @@ let get_conflict_point ctxt rollup staker1 staker2 = let* (commit2, ctxt) = find_staker ctxt rollup staker2 in let* () = fail_when - Commitment_hash.( + Sc_rollup_repr.Commitment_hash.( (* If PVM is in pre-boot state, there might be stakes on the zero commitment. *) commit1 = zero || commit2 = zero (* If either commit is the LCC, that also means there can't be a conflict. *) @@ -684,8 +689,8 @@ let get_conflict_point ctxt rollup staker1 staker2 = (* The inbox level of a commitment increases by a fixed amount over the preceding commitment. We use this fact in the following to efficiently traverse both commitment histories towards the conflict points. *) - let rec traverse_in_parallel ctxt commit1 commit2 = - if Commitment_hash.(commit1 = commit2) then + let[@coq_struct "commit1"] rec traverse_in_parallel ctxt commit1 commit2 = + if Sc_rollup_repr.Commitment_hash.(commit1 = commit2) then (* This case will most dominantly happen when either commit is part of the other's history. It occurs when the commit that is farther ahead gets dereferenced to its predecessor often enough to land at the other commit. *) @@ -695,7 +700,9 @@ let get_conflict_point ctxt rollup staker1 staker2 = let* (commit2_info, ctxt) = get_commitment_internal ctxt rollup commit2 in assert ( Raw_level_repr.(commit1_info.inbox_level = commit2_info.inbox_level)) ; - if Commitment_hash.(commit1_info.predecessor = commit2_info.predecessor) + if + Sc_rollup_repr.Commitment_hash.( + commit1_info.predecessor = commit2_info.predecessor) then (* Same predecessor means we've found the conflict points. *) return ((commit1, commit2), ctxt) @@ -715,14 +722,15 @@ let remove_staker ctxt rollup staker = match res with | None -> fail Sc_rollup_not_staked | Some staked_on -> - if Commitment_hash.(staked_on = lcc) then fail Sc_rollup_remove_lcc + if Sc_rollup_repr.Commitment_hash.(staked_on = lcc) then + fail Sc_rollup_remove_lcc else let* (ctxt, _size_diff) = Store.Stakers.remove_existing (ctxt, rollup) staker in let* ctxt = modify_staker_count ctxt rollup Int32.pred in - let rec go node ctxt = - if Commitment_hash.(node = lcc) then return ctxt + let[@coq_struct "node_value"] rec go node ctxt = + if Sc_rollup_repr.Commitment_hash.(node = lcc) then return ctxt else let* (pred, ctxt) = get_predecessor ctxt rollup node in let* ctxt = decrease_commitment_stake_count ctxt rollup node in diff --git a/src/proto_013_PtJakart/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_013_PtJakart/lib_protocol/sc_rollup_tick_repr.ml index e16ac07c91347..293bef4d2da88 100644 --- a/src/proto_013_PtJakart/lib_protocol/sc_rollup_tick_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/sc_rollup_tick_repr.ml @@ -24,13 +24,13 @@ (* *) (*****************************************************************************) -include Z +type t = Z.t -let initial = zero +let initial = Z.zero -let next = succ +let next = Z.succ -let pp = pp_print +let pp = Z.pp_print let encoding = Data_encoding.n @@ -40,16 +40,24 @@ let of_int x = if Compare.Int.(x < 0) then None else Some (Z.of_int x) let to_int x = if Z.fits_int x then Some (Z.to_int x) else None -let ( <= ) = leq +let ( <= ) = Z.leq -let ( < ) = lt +let ( < ) = Z.lt -let ( >= ) = geq +let ( >= ) = Z.geq -let ( > ) = gt +let ( > ) = Z.gt -let ( = ) = equal +let ( = ) = Z.equal let ( <> ) x y = not (x = y) +let compare = Z.compare + +let equal = Z.equal + +let min = Z.min + +let max = Z.max + module Map = Map.Make (Z) diff --git a/src/proto_013_PtJakart/lib_protocol/script_comparable.ml b/src/proto_013_PtJakart/lib_protocol/script_comparable.ml index 394285268528a..3b2b09b80504a 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_comparable.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_comparable.ml @@ -42,48 +42,63 @@ type compare_comparable_cont = -> compare_comparable_cont | Compare_comparable_return : compare_comparable_cont -let compare_comparable : type a. a comparable_ty -> a -> a -> int = - let rec compare_comparable : +module Compare_comparable = struct + let[@coq_struct "kind_value"] rec compare_comparable : type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int = fun kind k x y -> - match (kind, x, y) with - | (Unit_t, (), ()) -> (apply [@tailcall]) 0 k + match[@coq_match_gadt] [@coq_match_with_default] (kind, x, y) with + | (Unit_t, _, _) -> (apply [@tailcall]) 0 k | (Never_t, _, _) -> . - | (Signature_t, x, y) -> + | (Signature_t, (x : signature), (y : signature)) -> (apply [@tailcall]) (Script_signature.compare x y) k - | (String_t, x, y) -> (apply [@tailcall]) (Script_string.compare x y) k - | (Bool_t, x, y) -> (apply [@tailcall]) (Compare.Bool.compare x y) k - | (Mutez_t, x, y) -> (apply [@tailcall]) (Tez.compare x y) k - | (Key_hash_t, x, y) -> + | (String_t, (x : Script_string.t), (y : Script_string.t)) -> + (apply [@tailcall]) (Script_string.compare x y) k + | (Bool_t, (x : bool), (y : bool)) -> + (apply [@tailcall]) (Compare.Bool.compare x y) k + | (Mutez_t, (x : Tez.t), (y : Tez.t)) -> + (apply [@tailcall]) (Tez.compare x y) k + | (Key_hash_t, (x : public_key_hash), (y : public_key_hash)) -> (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k - | (Key_t, x, y) -> (apply [@tailcall]) (Signature.Public_key.compare x y) k - | (Int_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k - | (Nat_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k - | (Timestamp_t, x, y) -> + | (Key_t, (x : public_key), (y : public_key)) -> + (apply [@tailcall]) (Signature.Public_key.compare x y) k + | (Int_t, (x : _ Script_int.num), (y : _ Script_int.num)) -> + (apply [@tailcall]) (Script_int.compare x y) k + | (Nat_t, (x : _ Script_int.num), (y : _ Script_int.num)) -> + (apply [@tailcall]) (Script_int.compare x y) k + | (Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t)) -> (apply [@tailcall]) (Script_timestamp.compare x y) k - | (Address_t, x, y) -> (apply [@tailcall]) (compare_address x y) k - | (Tx_rollup_l2_address_t, x, y) -> + | (Address_t, (x : address), (y : address)) -> + (apply [@tailcall]) (compare_address x y) k + | ( Tx_rollup_l2_address_t, + (x : tx_rollup_l2_address), + (y : tx_rollup_l2_address) ) -> (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k - | (Bytes_t, x, y) -> (apply [@tailcall]) (Compare.Bytes.compare x y) k - | (Chain_id_t, x, y) -> (apply [@tailcall]) (Script_chain_id.compare x y) k - | (Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry)) -> + | (Bytes_t, (x : bytes), (y : bytes)) -> + (apply [@tailcall]) (Compare.Bytes.compare x y) k + | (Chain_id_t, (x : Script_chain_id.t), (y : Script_chain_id.t)) -> + (apply [@tailcall]) (Script_chain_id.compare x y) k + | (Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _)) -> + let (lx, rx) = x in + let (ly, ry) = y in (compare_comparable [@tailcall]) tl (Compare_comparable (tr, rx, ry, k)) lx ly - | (Union_t (tl, _, _, YesYes), L x, L y) -> - (compare_comparable [@tailcall]) tl k x y - | (Union_t _, L _, R _) -> -1 - | (Union_t _, R _, L _) -> 1 - | (Union_t (_, tr, _, YesYes), R x, R y) -> - (compare_comparable [@tailcall]) tr k x y - | (Option_t _, None, None) -> (apply [@tailcall]) 0 k - | (Option_t _, None, Some _) -> -1 - | (Option_t _, Some _, None) -> 1 - | (Option_t (t, _, Yes), Some x, Some y) -> - (compare_comparable [@tailcall]) t k x y - and apply ret k = + | (Union_t (tl, tr, _, YesYes), (x : (_, _) union), (y : (_, _) union)) -> ( + match (x, y) with + | (L x, L y) -> (compare_comparable [@tailcall]) tl k x y + | (L _, R _) -> -1 + | (R _, L _) -> 1 + | (R x, R y) -> (compare_comparable [@tailcall]) tr k x y) + | (Option_t (t, _, _), (x : _ option), (y : _ option)) -> ( + match (x, y) with + | (None, None) -> (apply [@tailcall]) 0 k + | (None, Some _) -> -1 + | (Some _, None) -> 1 + | (Some x, Some y) -> (compare_comparable [@tailcall]) t k x y) + + and[@coq_mutual_as_notation] apply ret k = match (ret, k) with | (0, Compare_comparable (ty, x, y, k)) -> (compare_comparable [@tailcall]) ty k x y @@ -91,6 +106,7 @@ let compare_comparable : type a. a comparable_ty -> a -> a -> int = | (ret, _) -> (* ret <> 0, we perform an early exit *) if Compare.Int.(ret > 0) then 1 else -1 - in - fun t -> compare_comparable t Compare_comparable_return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] +end + +let compare_comparable : type a. a comparable_ty -> a -> a -> int = + fun t -> Compare_comparable.compare_comparable t Compare_comparable_return diff --git a/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml b/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml index fba40417adb4d..9b74fcf18e1d6 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_int_repr.ml @@ -35,7 +35,7 @@ type z = Integer_tag having to deconstruct to and reconstruct from `Z.t`. *) type 't repr = Z.t -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] let compare (Num_tag x) (Num_tag y) = Z.compare x y diff --git a/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli b/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli index 1dbb5425330dc..7abe7e93c5697 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli +++ b/src/proto_013_PtJakart/lib_protocol/script_int_repr.mli @@ -34,7 +34,7 @@ type 't repr [@@coq_phantom] (** [num] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] (** Flag for natural numbers. *) type n = Natural_tag diff --git a/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml b/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml index 588b8fd06cb73..412f4825b50b0 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml @@ -234,6 +234,17 @@ let () = *) +let ifailwith : ifailwith_type = + { + ifailwith = + (fun logger (ctxt, _) gas kloc tv accu -> + let ctxt = update_context gas ctxt in + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv accu) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); + } + (* Evaluation of continuations @@ -247,19 +258,20 @@ let () = evaluation rules depending on the continuation at stake. *) -let rec kmap_exit : +let[@coq_mutual_as_notation] rec kmap_exit : type a b c d e f g h m n o. (a, b, c, d, e, f, g, h, m, n, o) kmap_exit_type = fun mk g gas (body, xs, ys, yk) ks accu stack -> let ys = Script_map.update yk (Some accu) ys in let ks = mk (KMap_enter_body (body, xs, ys, ks)) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = +and[@coq_mutual_as_notation] kmap_enter : + type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = fun mk g gas (body, xs, ys) ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack) | (xk, xv) :: xs -> let ks = mk (KMap_exit_body (body, xs, ys, xk, ks)) in @@ -268,16 +280,18 @@ and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = (step [@ocaml.tailcall]) g gas body ks res stack [@@inline] -and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = +and[@coq_mutual_as_notation] klist_exit : + type a b c d i j. (a, b, c, d, i, j) klist_exit_type = fun mk g gas (body, xs, ys, len) ks accu stack -> let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = +and[@coq_mutual_as_notation] klist_enter : + type a b c d e j. (a, b, c, d, e, j) klist_enter_type = fun mk g gas (body, xs, ys, len) ks' accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> let ys = {elements = List.rev ys; length = len} in (next [@ocaml.tailcall]) g gas ks' ys (accu, stack) @@ -286,31 +300,34 @@ and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type - = +and[@coq_mutual_as_notation] kloop_in_left : + type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = fun g gas ks0 ki ks' accu stack -> - match accu with + match[@coq_type_annotation] accu with | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack | R v -> (next [@ocaml.tailcall]) g gas ks' v stack [@@inline] -and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = +and[@coq_mutual_as_notation] kloop_in : + type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> let (accu', stack') = stack in - if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' + if [@coq_type_annotation] accu then + (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] -and kiter : type a b s r f. (a, b, s, r, f) kiter_type = +and[@coq_mutual_as_notation] kiter : type a b s r f. (a, b, s, r, f) kiter_type + = fun mk g gas (body, xs) ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks accu stack | x :: xs -> let ks = mk (KIter (body, xs, ks)) in (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and next : +and[@coq_struct "gas"] next : type a s r f. outdated_context * step_constants -> local_gas_counter -> @@ -318,38 +335,43 @@ and next : a -> s -> (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = - fun ((ctxt, _) as g) gas ks0 accu stack -> + fun g gas ks0 accu stack -> + let (ctxt, _) = g in match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match ks0 with - | KLog (ks, logger) -> + match[@coq_match_gadt] (ks0, accu, stack) with + | (KLog (ks, logger), _, _) -> (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack - | KNil -> Lwt.return (Ok (accu, stack, ctxt, gas)) - | KCons (k, ks) -> (step [@ocaml.tailcall]) g gas k ks accu stack - | KLoop_in (ki, ks') -> + | (KNil, (accu : r), (stack : f)) -> + Lwt.return (Ok (accu, stack, ctxt, gas)) + | (KCons (k, ks), _, _) -> (step [@ocaml.tailcall]) g gas k ks accu stack + | (KLoop_in (ki, ks'), (accu : bool), (stack : _ * _)) -> (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks) -> (next [@ocaml.tailcall]) g gas ks accu stack' - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | (KReturn (stack', ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks accu stack' + | (KMap_head (f, ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks (f accu) stack + | (KLoop_in_left (ki, ks'), (accu : _ union), _) -> (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks) -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) - | KIter (body, xs, ks) -> + | (KUndip (x, ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks x (accu, stack) + | (KIter (body, xs, ks), _, _) -> let extra = (body, xs) in (kiter [@ocaml.tailcall]) id g gas extra ks accu stack - | KList_enter_body (body, xs, ys, len, ks) -> + | (KList_enter_body (body, xs, ys, len, ks), _, _) -> let extra = (body, xs, ys, len) in (klist_enter [@ocaml.tailcall]) id g gas extra ks accu stack - | KList_exit_body (body, xs, ys, len, ks) -> + | (KList_exit_body (body, xs, ys, len, ks), _, (stack : _ * _)) -> let extra = (body, xs, ys, len) in (klist_exit [@ocaml.tailcall]) id g gas extra ks accu stack - | KMap_enter_body (body, xs, ys, ks) -> + | (KMap_enter_body (body, xs, ys, ks), _, _) -> let extra = (body, xs, ys) in (kmap_enter [@ocaml.tailcall]) id g gas extra ks accu stack - | KMap_exit_body (body, xs, ys, yk, ks) -> + | (KMap_exit_body (body, xs, ys, yk, ks), _, (stack : _ * _)) -> let extra = (body, xs, ys, yk) in (kmap_exit [@ocaml.tailcall]) id g gas extra ks accu stack - | KView_exit (orig_step_constants, ks) -> + | (KView_exit (orig_step_constants, ks), _, _) -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks accu stack) @@ -366,102 +388,102 @@ and next : instructions. *) -and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = +and[@coq_mutual_as_notation] ilist_map : + type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = fun log_if_needed g gas (body, k) ks accu stack -> let xs = accu.elements in - let ys = [] in + let ys = (([] [@coq_type_annotation]) : f list) in let len = accu.length in let ks = log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = +and[@coq_mutual_as_notation] ilist_iter : + type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let xs = accu.elements in let ks = log_if_needed (KIter (body, xs, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = +and[@coq_mutual_as_notation] iset_iter : + type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let set = accu in let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type - = +and[@coq_mutual_as_notation] imap_map : + type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type = fun log_if_needed g gas (body, k) ks accu stack -> let map = accu in let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in - let ys = Script_map.empty_from map in + let ys = (Script_map.empty_from [@coq_type_annotation]) map in let ks = log_if_needed (KMap_enter_body (body, xs, ys, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = +and[@coq_mutual_as_notation] imap_iter : + type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let map = accu in let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = +and[@coq_mutual_as_notation] imul_teznat : + type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in let (y, stack) = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = +and[@coq_mutual_as_notation] imul_nattez : + type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas (kinfo, k) ks accu stack -> let y = accu in let (x, stack) = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = +and[@coq_mutual_as_notation] ilsl_nat : + type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in - match Script_int.shift_left_n x y with + let x = accu in + let (y, stack) = stack in + match[@coq_type_annotation] Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack -and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = +and[@coq_mutual_as_notation] ilsr_nat : + type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in - match Script_int.shift_right_n x y with + let x = accu in + let (y, stack) = stack in + match[@coq_type_annotation] Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack -and ifailwith : ifailwith_type = - { - ifailwith = - (fun logger (ctxt, _) gas kloc tv accu -> - let v = accu in - let ctxt = update_context gas ctxt in - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) - >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); - } - -and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = +and[@coq_mutual_as_notation] iexec : + type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> - let arg = accu and (code, stack) = stack in + let arg = accu in + let (code, stack) = stack in let (Lam (code, _)) = code in let code = match logger with @@ -469,32 +491,49 @@ and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = | Some logger -> log_kinstr logger code.kinstr in let ks = KReturn (stack, KCons (k, ks)) in - (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell) - -and step : type a s b t r f. (a, s, b, t, r, f) step_type = - fun ((ctxt, sc) as g) gas i ks accu stack -> + ((step [@ocaml.tailcall]) + g + gas + code + ks + arg + (EmptyCell, EmptyCell) [@coq_type_annotation]) + +and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = + fun g gas i ks accu stack -> + let (ctxt, sc) = g in match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match i with - | ILog (_, event, logger, k) -> + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | (ILog (_, event, logger, k), _, _) -> (log [@ocaml.tailcall]) (logger, event) g gas k ks accu stack - | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack + | (IHalt _, _, _) -> (next [@ocaml.tailcall]) g gas ks accu stack (* stack ops *) - | IDrop (_, k) -> + | (IDrop (_, k), _, (stack : _ * _)) -> let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) - | ISwap (_, k) -> + | (IDup (_, k), _, _) -> + (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) + | (ISwap (_, k), _, (stack : _ * _)) -> let (top, stack) = stack in (step [@ocaml.tailcall]) g gas k ks top (accu, stack) - | IConst (_, v, k) -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) + | (IConst (_, v, k), _, _) -> + (step [@ocaml.tailcall]) g gas k ks v (accu, stack) (* options *) - | ICons_some (_, k) -> + | (ICons_some (_, k), _, _) -> (step [@ocaml.tailcall]) g gas k ks (Some accu) stack - | ICons_none (_, k) -> - (step [@ocaml.tailcall]) g gas k ks None (accu, stack) - | IIf_none {branch_if_none; branch_if_some; k; _} -> ( + | (ICons_none (_, k), _, _) -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + (accu, stack) + | ( IIf_none {branch_if_none; branch_if_some; k; _}, + (accu : _ option), + (stack : _ * _) ) -> ( match accu with | None -> let (accu, stack) = stack in @@ -513,29 +552,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) v stack) - | IOpt_map {body; k; kinfo = _} -> ( + | (IOpt_map {body; k; kinfo = _}, (accu : _ option), _) -> ( match accu with - | None -> (step [@ocaml.tailcall]) g gas k ks None stack + | None -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack | Some v -> - let ks' = KMap_head (Option.some, KCons (k, ks)) in + let ks' = + KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks)) + in (step [@ocaml.tailcall]) g gas body ks' v stack) (* pairs *) - | ICons_pair (_, k) -> + | (ICons_pair (_, k), _, (stack : _ * _)) -> let (b, stack) = stack in (step [@ocaml.tailcall]) g gas k ks (accu, b) stack - | IUnpair (_, k) -> + | (IUnpair (_, k), (accu : _ * _), _) -> let (a, b) = accu in (step [@ocaml.tailcall]) g gas k ks a (b, stack) - | ICar (_, k) -> + | (ICar (_, k), (accu : _ * _), _) -> let (a, _) = accu in (step [@ocaml.tailcall]) g gas k ks a stack - | ICdr (_, k) -> + | (ICdr (_, k), (accu : _ * _), _) -> let (_, b) = accu in (step [@ocaml.tailcall]) g gas k ks b stack (* unions *) - | ICons_left (_, k) -> (step [@ocaml.tailcall]) g gas k ks (L accu) stack - | ICons_right (_, k) -> (step [@ocaml.tailcall]) g gas k ks (R accu) stack - | IIf_left {branch_if_left; branch_if_right; k; _} -> ( + | (ICons_left (_, k), _, _) -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (L accu [@coq_type_annotation]) + stack + | (ICons_right (_, k), _, _) -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (R accu [@coq_type_annotation]) + stack + | (IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _) + -> ( match accu with | L v -> (step [@ocaml.tailcall]) @@ -554,15 +617,23 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = v stack) (* lists *) - | ICons_list (_, k) -> + | (ICons_list (_, k), _, (stack : _ * _)) -> let (tl, stack) = stack in let accu = Script_list.cons accu tl in (step [@ocaml.tailcall]) g gas k ks accu stack - | INil (_, k) -> + | (INil (_, k), _, _) -> let stack = (accu, stack) in let accu = Script_list.empty in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> ( + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_implicit "E" "__INil_'b"]) + stack + | ( IIf_cons {branch_if_cons; branch_if_nil; k; _}, + (accu : _ boxed_list), + (stack : _ * _) ) -> ( match accu.elements with | [] -> let (accu, stack) = stack in @@ -582,88 +653,115 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) hd (tl, stack)) - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | IList_size (_, k) -> + | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"]) + id + g + gas + (body, k) + ks + accu + stack + | (IList_size (_, k), (accu : _ boxed_list), _) -> let list = accu in let len = Script_int.(abs (of_int list.length)) in (step [@ocaml.tailcall]) g gas k ks len stack - | IList_iter (_, body, k) -> + | (IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> (ilist_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack (* sets *) - | IEmpty_set (_, ty, k) -> - let res = Script_set.empty ty in + | (IEmpty_set (_, ty, k), _, _) -> + let res = (Script_set.empty [@coq_type_annotation]) ty in let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_iter (_, body, k) -> + | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) -> (iset_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | ISet_mem (_, k) -> + | (ISet_mem (_, k), _, (stack : _ * _)) -> let (set, stack) = stack in let res = Script_set.mem accu set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_update (_, k) -> + | (ISet_update (_, k), _, (stack : _ * (_ * _))) -> let (presence, (set, stack)) = stack in let res = Script_set.update accu presence set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_size (_, k) -> + | (ISet_size (_, k), (accu : _ set), _) -> let res = Script_set.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* maps *) - | IEmpty_map (_, ty, k) -> - let res = Script_map.empty ty and stack = (accu, stack) in + | (IEmpty_map (_, ty, k), _, _) -> + let stack = (accu, stack) in + let res = (Script_map.empty [@coq_type_annotation]) ty in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | IMap_iter (_, body, k) -> + | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"]) + id + g + gas + (body, k) + ks + accu + stack + | (IMap_iter (_, body, k), (accu : _ map), (stack : _ * _)) -> (imap_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | IMap_mem (_, k) -> + | (IMap_mem (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let res = Script_map.mem accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get (_, k) -> + | (IMap_get (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let res = Script_map.get accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_update (_, k) -> + | (IMap_update (_, k), _, (stack : _ * (_ * _))) -> let (v, (map, stack)) = stack in let key = accu in let res = Script_map.update key v map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get_and_update (_, k) -> + | (IMap_get_and_update (_, k), _, (stack : _ * (_ * _))) -> let key = accu in let (v, (map, rest)) = stack in let map' = Script_map.update key v map in let v' = Script_map.get key map in (step [@ocaml.tailcall]) g gas k ks v' (map', rest) - | IMap_size (_, k) -> + | (IMap_size (_, k), (accu : _ map), _) -> let res = Script_map.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* Big map operations *) - | IEmpty_big_map (_, tk, tv, k) -> - let ebm = Script_ir_translator.empty_big_map tk tv in + | (IEmpty_big_map (_, tk, tv, k), _, _) -> + let ebm = + (Script_ir_translator.empty_big_map + [@coq_implicit "a" "__IEmpty_big_map_'b"] + [@coq_implicit "b" "__IEmpty_big_map_'c"]) + tk + tv + in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) - | IBig_map_mem (_, k) -> + | (IBig_map_mem (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_mem ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_get (_, k) -> + | (IBig_map_get (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_get ctxt key map ) >>=? fun (res, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_update (_, k) -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (res [@coq_type_annotation]) + stack + | (IBig_map_update (_, k), _, (stack : _ * (_ * _))) -> let key = accu in let (maybe_value, (map, stack)) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_update ctxt key maybe_value map ) >>=? fun (big_map, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack - | IBig_map_get_and_update (_, k) -> + | (IBig_map_get_and_update (_, k), _, (stack : _ * (_ * _))) -> let key = accu in let (v, (map, stack)) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> @@ -671,33 +769,41 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = >>=? fun ((v', map'), ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack) (* timestamp operations *) - | IAdd_seconds_to_timestamp (_, k) -> + | ( IAdd_seconds_to_timestamp (_, k), + (accu : _ Script_int.num), + (stack : _ * _) ) -> let n = accu in let (t, stack) = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | IAdd_timestamp_to_seconds (_, k) -> + | ( IAdd_timestamp_to_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let (n, stack) = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | ISub_timestamp_seconds (_, k) -> + | ( ISub_timestamp_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let (s, stack) = stack in let result = Script_timestamp.sub_delta t s in (step [@ocaml.tailcall]) g gas k ks result stack - | IDiff_timestamps (_, k) -> + | (IDiff_timestamps (_, k), (accu : Script_timestamp.t), (stack : _ * _)) + -> let t1 = accu in let (t2, stack) = stack in let result = Script_timestamp.diff t1 t2 in (step [@ocaml.tailcall]) g gas k ks result stack (* string operations *) - | IConcat_string_pair (_, k) -> + | (IConcat_string_pair (_, k), (accu : Script_string.t), (stack : _ * _)) + -> let x = accu in let (y, stack) = stack in let s = Script_string.concat_pair x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_string (_, k) -> + | (IConcat_string (_, k), (accu : _ boxed_list), _) -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -709,8 +815,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_string (_, k) -> - let offset = accu and (length, (s, stack)) = stack in + | ( ISlice_string (_, k), + (accu : _ Script_int.num), + (stack : _ * (Script_string.t * _)) ) -> + let offset = accu in + let (length, (s, stack)) = stack in let s_length = Z.of_int (Script_string.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -718,18 +827,25 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IString_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | (IString_size (_, k), (accu : Script_string.t), _) -> let s = accu in let result = Script_int.(abs (of_int (Script_string.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* bytes operations *) - | IConcat_bytes_pair (_, k) -> + | (IConcat_bytes_pair (_, k), (accu : bytes), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let s = Bytes.cat x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_bytes (_, k) -> + | (IConcat_bytes (_, k), (accu : _ boxed_list), _) -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -741,8 +857,10 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Bytes.concat Bytes.empty ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_bytes (_, k) -> - let offset = accu and (length, (s, stack)) = stack in + | (ISlice_bytes (_, k), (accu : _ Script_int.num), (stack : _ * (_ * _))) + -> + let offset = accu in + let (length, (s, stack)) = stack in let s_length = Z.of_int (Bytes.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -750,87 +868,102 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IBytes_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | (IBytes_size (_, k), (accu : bytes), _) -> let s = accu in let result = Script_int.(abs (of_int (Bytes.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* currency operations *) - | IAdd_tez (_, k) -> + | (IAdd_tez (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in Tez.(x +? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez (_, k) -> + | (ISub_tez (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Tez.sub_opt x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez_legacy (_, k) -> + | (ISub_tez_legacy (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_teznat (kinfo, k) -> + | (IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _)) + -> imul_teznat None g gas (kinfo, k) ks accu stack - | IMul_nattez (kinfo, k) -> + | (IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _)) + -> imul_nattez None g gas (kinfo, k) ks accu stack (* boolean operations *) - | IOr (_, k) -> + | (IOr (_, k), (accu : bool), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in (step [@ocaml.tailcall]) g gas k ks (x || y) stack - | IAnd (_, k) -> + | (IAnd (_, k), (accu : bool), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in (step [@ocaml.tailcall]) g gas k ks (x && y) stack - | IXor (_, k) -> + | (IXor (_, k), (accu : bool), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Compare.Bool.(x <> y) in (step [@ocaml.tailcall]) g gas k ks res stack - | INot (_, k) -> + | (INot (_, k), (accu : bool), _) -> let x = accu in (step [@ocaml.tailcall]) g gas k ks (not x) stack (* integer operations *) - | IIs_nat (_, k) -> + | (IIs_nat (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.is_nat x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAbs_int (_, k) -> + | (IAbs_int (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.abs x in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_nat (_, k) -> + | (IInt_nat (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.int x in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg (_, k) -> + | (INeg (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.neg x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_int (_, k) -> - let x = accu and (y, stack) = stack in + | (IAdd_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.add x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_nat (_, k) -> - let x = accu and (y, stack) = stack in + | (IAdd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.add_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_int (_, k) -> - let x = accu and (y, stack) = stack in + | (ISub_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.sub x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_int (_, k) -> - let x = accu and (y, stack) = stack in + | (IMul_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_nat (_, k) -> - let x = accu and (y, stack) = stack in + | (IMul_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.mul_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_teznat (_, k) -> - let x = accu and (y, stack) = stack in + | (IEdiv_teznat (_, k), (accu : Tez.t), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let x = Script_int.of_int64 (Tez.to_mutez x) in let result = match Script_int.ediv x y with @@ -846,8 +979,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | _ -> assert false) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_tez (_, k) -> - let x = accu and (y, stack) = stack in + | (IEdiv_tez (_, k), (accu : Tez.t), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in 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 let result = @@ -862,38 +996,54 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some r -> Some (q, r))) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_int (_, k) -> - let x = accu and (y, stack) = stack in + | ( IEdiv_int (_, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.ediv x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_nat (_, k) -> - let x = accu and (y, stack) = stack in + | (IEdiv_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (kinfo, k) -> ilsl_nat None g gas (kinfo, k) ks accu stack - | ILsr_nat (kinfo, k) -> ilsr_nat None g gas (kinfo, k) ks accu stack - | IOr_nat (_, k) -> - let x = accu and (y, stack) = stack in + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsl_nat None g gas (kinfo, k) ks accu stack + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsr_nat None g gas (kinfo, k) ks accu stack + | (IOr_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.logor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_nat (_, k) -> - let x = accu and (y, stack) = stack in + | (IAnd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_int_nat (_, k) -> - let x = accu and (y, stack) = stack in + | (IAnd_int_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IXor_nat (_, k) -> - let x = accu and (y, stack) = stack in + | (IXor_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> + let x = accu in + let (y, stack) = stack in let res = Script_int.logxor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | INot_int (_, k) -> + | (INot_int (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.lognot x in (step [@ocaml.tailcall]) g gas k ks res stack (* control *) - | IIf {branch_if_true; branch_if_false; k; _} -> + | ( IIf {branch_if_true; branch_if_false; k; _}, + (accu : bool), + (stack : _ * _) ) -> let (res, stack) = stack in if accu then (step [@ocaml.tailcall]) @@ -911,30 +1061,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) res stack - | ILoop (_, body, k) -> + | (ILoop (_, body, k), _, _) -> let ks = KLoop_in (body, KCons (k, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | (ILoop_left (_, bl, br), _, _) -> let ks = KLoop_in_left (bl, KCons (br, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | IDip (_, b, k) -> + | (IDip (_, b, k), _, (stack : _ * _)) -> let ign = accu in let ks = KUndip (ign, KCons (k, ks)) in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas b ks accu stack - | IExec (_, k) -> iexec None g gas k ks accu stack - | IApply (_, capture_ty, k) -> + | (IExec (_, k), _, (stack : _ lambda * _)) -> + iexec None g gas k ks accu stack + | (IApply (_, capture_ty, k), _, (stack : _ lambda * _)) -> let capture = accu in let (lam, stack) = stack in apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack - | ILambda (_, lam, k) -> + | (ILambda (_, lam, k), _, _) -> (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) - | IFailwith (_, kloc, tv) -> + | (IFailwith (_, kloc, tv), _, _) -> let {ifailwith} = ifailwith in ifailwith None g gas kloc tv accu (* comparison *) - | ICompare (_, ty, k) -> + | (ICompare (_, ty, k), _, (stack : _ * _)) -> let a = accu in let (b, stack) = stack in let r = @@ -942,53 +1093,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks r stack (* comparators *) - | IEq (_, k) -> + | (IEq (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a = 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | INeq (_, k) -> + | (INeq (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <> 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILt (_, k) -> + | (ILt (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a < 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILe (_, k) -> + | (ILe (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <= 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGt (_, k) -> + | (IGt (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a > 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGe (_, k) -> + | (IGe (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a >= 0) in (step [@ocaml.tailcall]) g gas k ks a stack (* packing *) - | IPack (_, ty, k) -> + | (IPack (_, ty, k), _, _) -> let value = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.pack_data ctxt ty value ) >>=? fun (bytes, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack - | IUnpack (_, ty, k) -> + | (IUnpack (_, ty, k), (accu : bytes), _) -> let bytes = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - unpack ctxt ~ty ~bytes ) + (unpack [@coq_type_annotation]) ctxt ~ty ~bytes ) >>=? fun (opt, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack - | IAddress (_, k) -> + | (IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _) -> let (Typed_contract {address; _}) = accu in (step [@ocaml.tailcall]) g gas k ks address stack - | IContract (kinfo, t, entrypoint, k) -> ( + | (IContract (kinfo, t, entrypoint, k), (accu : address), _) -> ( let addr = accu in let entrypoint_opt = if Entrypoint.is_default addr.entrypoint then Some entrypoint @@ -1008,8 +1159,16 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ITransfer_tokens (kinfo, k) -> + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | (ITransfer_tokens (kinfo, k), _, (stack : _ * (_ typed_contract * _))) + -> let p = accu in let (amount, (Typed_contract {arg_ty; address}, stack)) = stack in let {destination; entrypoint} = address in @@ -1024,7 +1183,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = entrypoint >>=? fun (accu, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | IImplicit_account (_, k) -> + | (IImplicit_account (_, k), (accu : public_key_hash), _) -> let key = accu in let arg_ty = unit_t in let address = @@ -1035,14 +1194,22 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let res = Typed_contract {arg_ty; address} in (step [@ocaml.tailcall]) g gas k ks res stack - | IView (_, View_signature {name; input_ty; output_ty}, k) -> ( + | ( IView (_, View_signature {name; input_ty; output_ty}, k), + _, + (stack : address * _) ) -> ( let input = accu in let (addr, stack) = stack in let c = addr.destination in let ctxt = update_context gas ctxt in let return_none ctxt = let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack in match c with | Contract c -> ( @@ -1055,8 +1222,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = ~allow_forged_in_storage:true ctxt script - >>=? fun ( Ex_script (Script {storage; storage_type; views; _}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + storage; + storage_type; + views; + _; + }), + ctxt ) -> Gas.consume ctxt (Interp_costs.view_get name views) >>?= fun ctxt -> match Script_map.get name views with @@ -1130,7 +1304,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (input, storage) (EmptyCell, EmptyCell))))) | Tx_rollup _ -> (return_none [@ocaml.tailcall]) ctxt) - | ICreate_contract {storage_type; code; k; kinfo = _} -> + | ( ICreate_contract {storage_type; code; k; kinfo = _}, + (accu : public_key_hash option), + (stack : _ * (_ * _)) ) -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in let (credit, (init, stack)) = stack in @@ -1141,24 +1317,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = stack ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | ISet_delegate (_, k) -> + | (ISet_delegate (_, k), (accu : public_key_hash option), _) -> let delegate = accu in let operation = Delegation delegate in let ctxt = update_context gas ctxt in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in - let res = {piop; lazy_storage_diff = None} in + let res = + { + piop; + lazy_storage_diff = + (None [@coq_type_annotation] : Lazy_storage.diffs option); + } + in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBalance (_, k) -> + | (IBalance (_, k), _, _) -> let ctxt = update_context gas ctxt in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack) - | ILevel (_, k) -> + | (ILevel (_, k), _, _) -> (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack) - | INow (_, k) -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) - | IMin_block_time (_, k) -> + | (INow (_, k), _, _) -> + (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) + | (IMin_block_time (_, k), _, _) -> let ctxt = update_context gas ctxt in let min_block_time = Alpha_context.Constants.minimal_block_delay ctxt @@ -1168,47 +1351,49 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let new_stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack - | ICheck_signature (_, k) -> - let key = accu and (signature, (message, stack)) = stack in + | (ICheck_signature (_, k), (accu : public_key), (stack : _ * (_ * _))) -> + let key = accu in + let (signature, (message, stack)) = stack in let res = Script_signature.check key signature message in (step [@ocaml.tailcall]) g gas k ks res stack - | IHash_key (_, k) -> + | (IHash_key (_, k), (accu : public_key), _) -> let key = accu in let res = Signature.Public_key.hash key in (step [@ocaml.tailcall]) g gas k ks res stack - | IBlake2b (_, k) -> + | (IBlake2b (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.blake2b bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha256 (_, k) -> + | (ISha256 (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.sha256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha512 (_, k) -> + | (ISha512 (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.sha512 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISource (_, k) -> + | (ISource (_, k), _, _) -> let destination : Destination.t = Contract sc.payer in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISender (_, k) -> + | (ISender (_, k), _, _) -> let destination : Destination.t = Contract sc.source in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf (_, ty, entrypoint, k) -> + | (ISelf (_, ty, entrypoint, k), _, _) -> let destination : Destination.t = Contract sc.self in let address = {destination; entrypoint} in let res = Typed_contract {arg_ty = ty; address} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf_address (_, k) -> + | (ISelf_address (_, k), _, _) -> let destination : Destination.t = Contract sc.self in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | IAmount (_, k) -> - let accu = sc.amount and stack = (accu, stack) in + | (IAmount (_, k), _, _) -> + let stack = (accu, stack) in + let accu = sc.amount in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDig (_, _n, n', k) -> + | (IDig (_, _n, n', k), _, _) -> let ((accu, stack), x) = interp_stack_prefix_preserving_operation (fun v stack -> (stack, v)) @@ -1216,9 +1401,10 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - let accu = x and stack = (accu, stack) in + let stack = ((accu, stack) [@coq_type_annotation]) in + let accu = x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDug (_, _n, n', k) -> + | (IDug (_, _n, n', k), _, (stack : _ * _)) -> let v = accu in let (accu, stack) = stack in let ((accu, stack), ()) = @@ -1228,34 +1414,44 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IDipn (_, _n, n', b, k) -> - let (accu, stack, restore_prefix) = kundip n' accu stack k in + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_type_annotation]) + (stack [@coq_type_annotation]) + | (IDipn (_, _n, n', b, k), _, _) -> + let (accu, stack, restore_prefix) = + (kundip [@coq_type_annotation]) n' accu stack k + in let ks = KCons (restore_prefix, ks) in (step [@ocaml.tailcall]) g gas b ks accu stack - | IDropn (_, _n, n', k) -> + | (IDropn (_, _n, n', k), _, _) -> let stack = - let rec aux : + let[@coq_struct "w_value"] rec aux : type a s b t. (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness -> a -> s -> b * t = fun w accu stack -> - match w with - | KRest -> (accu, stack) - | KPrefix (_, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | (KRest, (accu : b), (stack : t)) -> (accu, stack) + | (KPrefix (_, w), _, (stack : _ * _)) -> let (accu, stack) = stack in aux w accu stack in - aux n' accu stack + (aux [@coq_type_annotation]) n' accu stack in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISapling_empty_state (_, memo_size, k) -> + | (ISapling_empty_state (_, memo_size, k), _, _) -> let state = Sapling.empty_state ~memo_size () in (step [@ocaml.tailcall]) g gas k ks state (accu, stack) - | ISapling_verify_update (_, k) -> ( + | ( ISapling_verify_update (_, k), + (accu : Sapling.transaction), + (stack : _ * _) ) -> ( let transaction = accu in let (state, stack) = stack in let address = Contract.to_b58check sc.self in @@ -1274,8 +1470,17 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (Script_int.of_int64 balance, state) ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ISapling_verify_update_deprecated (_, k) -> ( + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | ( ISapling_verify_update_deprecated (_, k), + (accu : Sapling_repr.legacy_transaction), + (stack : _ * _) ) -> ( let transaction = accu in let (state, stack) = stack in let address = Contract.to_b58check sc.self in @@ -1290,171 +1495,223 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some (balance, state) -> let state = Some (Script_int.of_int64 balance, state) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | IChainId (_, k) -> - let accu = Script_chain_id.make sc.chain_id - and stack = (accu, stack) in + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | (IChainId (_, k), _, _) -> + let stack = (accu, stack) in + let accu = Script_chain_id.make sc.chain_id in (step [@ocaml.tailcall]) g gas k ks accu stack - | INever _ -> ( match accu with _ -> .) - | IVoting_power (_, k) -> + | (INever _, _, _) -> . + | (IVoting_power (_, k), (accu : public_key_hash), _) -> let key_hash = accu in let ctxt = update_context gas ctxt in Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack - | ITotal_voting_power (_, k) -> + | (ITotal_voting_power (_, k), _, _) -> let ctxt = update_context gas ctxt in Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks power (accu, stack) - | IKeccak (_, k) -> + | (IKeccak (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.keccak256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha3 (_, k) -> + | (ISha3 (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | IAdd_bls12_381_g1 (_, k) -> - let x = accu and (y, stack) = stack in + | ( IAdd_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.G1.t * _) ) -> + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_g2 (_, k) -> - let x = accu and (y, stack) = stack in + | ( IAdd_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.G2.t * _) ) -> + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_fr (_, k) -> - let x = accu and (y, stack) = stack in + | ( IAdd_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let (y, stack) = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g1 (_, k) -> - let x = accu and (y, stack) = stack in + | ( IMul_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g2 (_, k) -> - let x = accu and (y, stack) = stack in + | ( IMul_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr (_, k) -> - let x = accu and (y, stack) = stack in + | ( IMul_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let (y, stack) = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr_z (_, k) -> - let x = accu and (y, stack) = stack in + | ( IMul_bls12_381_fr_z (_, k), + (accu : _ Script_int.num), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let (y, stack) = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_bls12_381_z_fr (_, k) -> - let y = accu and (x, stack) = stack in + | ( IMul_bls12_381_z_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : _ Script_int.num * _) ) -> + let y = accu in + let (x, stack) = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_bls12_381_fr (_, k) -> + | (IInt_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _) -> let x = accu in let res = Script_int.of_zint (Script_bls.Fr.to_z x) in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg_bls12_381_g1 (_, k) -> + | (INeg_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), _) -> let x = accu in let accu = Script_bls.G1.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_g2 (_, k) -> + | (INeg_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), _) -> let x = accu in let accu = Script_bls.G2.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_fr (_, k) -> + | (INeg_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _) -> let x = accu in let accu = Script_bls.Fr.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IPairing_check_bls12_381 (_, k) -> + | (IPairing_check_bls12_381 (_, k), (accu : _ boxed_list), _) -> let pairs = accu in let check = Script_bls.pairing_check pairs.elements in (step [@ocaml.tailcall]) g gas k ks check stack - | IComb (_, _, witness, k) -> - let rec aux : + | (IComb (_, _, witness, k), _, _) -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | (Comb_one, stack) -> stack - | (Comb_succ witness', (a, tl)) -> - let (b, tl') = aux witness' tl in - ((a, b), tl') + match[@coq_match_gadt] (witness, stack) with + | (Comb_one, (stack : after)) -> stack + | (Comb_succ witness', (stack : _ * _)) -> + let (a, tl) = stack in + let (b, tl') = (aux [@coq_type_annotation]) witness' tl in + ((((a, b), tl') [@coq_cast]) : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IUncomb (_, _, witness, k) -> - let rec aux : + | (IUncomb (_, _, witness, k), _, _) -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) uncomb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | (Uncomb_one, stack) -> stack - | (Uncomb_succ witness', ((a, b), tl)) -> (a, aux witness' (b, tl)) + match[@coq_match_gadt] (witness, stack) with + | (Uncomb_one, (stack : after)) -> stack + | (Uncomb_succ witness', (stack : (_ * _) * _)) -> + let ((a, b), tl) = stack in + (((a, (aux [@coq_type_annotation]) witness' (b, tl)) + [@coq_cast]) + : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_get (_, _, witness, k) -> + | (IComb_get (_, _, witness, k), _, _) -> let comb = accu in - let rec aux : + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_get_gadt_witness -> before -> after = fun witness comb -> - match (witness, comb) with - | (Comb_get_zero, v) -> v - | (Comb_get_one, (a, _)) -> a - | (Comb_get_plus_two witness', (_, b)) -> aux witness' b + match[@coq_match_gadt] (witness, comb) with + | (Comb_get_zero, (v : after)) -> v + | (Comb_get_one, (comb : after * _)) -> + let (a, _) = comb in + a + | (Comb_get_plus_two witness', (comb : _ * _)) -> + let (_, b) = comb in + aux witness' b in - let accu = aux witness comb in + let accu = (aux [@coq_type_annotation]) witness comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_set (_, _, witness, k) -> - let value = accu and (comb, stack) = stack in - let rec aux : + | (IComb_set (_, _, witness, k), _, (stack : _ * _)) -> + let value = accu in + let (comb, stack) = stack in + let[@coq_struct "witness"] rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> value -> before -> after = fun witness value item -> - match (witness, item) with - | (Comb_set_zero, _) -> value - | (Comb_set_one, (_hd, tl)) -> (value, tl) - | (Comb_set_plus_two witness', (hd, tl)) -> - (hd, aux witness' value tl) + match[@coq_match_gadt] (witness, value, item) with + | (Comb_set_zero, (value : after), _) -> value + | (Comb_set_one, _, (item : _ * _)) -> + let (_hd, tl) = item in + (((value, tl) [@coq_cast]) : after) + | (Comb_set_plus_two witness', _, (item : _ * _)) -> + let (hd, tl) = item in + (((hd, (aux [@coq_type_annotation]) witness' value tl) + [@coq_cast]) + : after) in - let accu = aux witness value comb in + let accu = (aux [@coq_type_annotation]) witness value comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup_n (_, _, witness, k) -> - let rec aux : + | (IDup_n (_, _, witness, k), _, _) -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) dup_n_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | (Dup_n_zero, (a, _)) -> a - | (Dup_n_succ witness', (_, tl)) -> aux witness' tl + match[@coq_match_gadt] (witness, stack) with + | (Dup_n_zero, (stack : after * _)) -> + let (a, _) = stack in + a + | (Dup_n_succ witness', (stack : _ * _)) -> + let (_, tl) = stack in + aux witness' tl in let stack = (accu, stack) in - let accu = aux witness stack in + let accu = (aux [@coq_type_annotation]) witness stack in (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) - | ITicket (_, k) -> - let contents = accu and (amount, stack) = stack in + | (ITicket (_, k), _, (stack : _ * _)) -> + let contents = accu in + let (amount, stack) = stack in let ticketer = sc.self in let accu = {ticketer; contents; amount} in (step [@ocaml.tailcall]) g gas k ks accu stack - | IRead_ticket (_, k) -> + | (IRead_ticket (_, k), (accu : _ ticket), _) -> let {ticketer; contents; amount} = accu in let stack = (accu, stack) in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in let accu = (addr, (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISplit_ticket (_, k) -> - let ticket = accu and ((amount_a, amount_b), stack) = stack in + | (ISplit_ticket (_, k), (accu : _ ticket), (stack : (_ * _) * _)) -> + let ticket = accu in + let ((amount_a, amount_b), stack) = stack in let result = if Compare.Int.( @@ -1466,7 +1723,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IJoin_tickets (_, contents_ty, k) -> + | (IJoin_tickets (_, contents_ty, k), (accu : _ ticket * _ ticket), _) -> let (ticket_a, ticket_b) = accu in let result = if @@ -1487,7 +1744,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IOpen_chest (_, k) -> + | ( IOpen_chest (_, k), + (accu : Script_timelock.chest_key), + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> let open Timelock in let chest_key = accu in let (chest, (time_z, stack)) = stack in @@ -1529,7 +1788,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = that starts the evaluation. *) -and log : +and[@coq_axiom_with_reason "we ignore the logging operations"] log : type a s b t r f. logger * logging_event -> (a, s, b, t, r, f) step_type = fun (logger, event) ((ctxt, _) as g) gas k ks accu stack -> (match (k, event) with @@ -1538,44 +1797,62 @@ and log : | (_, LogExit prev_kinfo) -> log_exit logger ctxt gas prev_kinfo k accu stack) ; let k = log_next_kinstr logger k in let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match k with - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | IList_iter (_, body, k) -> + match[@coq_match_gadt] (k, accu, stack) with + | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b2"]) + with_log + g + gas + (body, k) + ks + accu + stack + | (IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> (ilist_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | ISet_iter (_, body, k) -> + | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) -> (iset_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | IMap_iter (_, body, k) -> + | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"]) + with_log + g + gas + (body, k) + ks + accu + stack + | (IMap_iter (_, body, k), (accu : _ map), (stack : _ * _)) -> (imap_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | ILoop (_, body, k) -> + | (ILoop (_, body, k), _, _) -> let ks = with_log (KLoop_in (body, KCons (k, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | (ILoop_left (_, bl, br), _, _) -> let ks = with_log (KLoop_in_left (bl, KCons (br, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | IMul_teznat (kinfo, k) -> + | (IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _)) -> let extra = (kinfo, k) in (imul_teznat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | IMul_nattez (kinfo, k) -> + | (IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _)) -> let extra = (kinfo, k) in (imul_nattez [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | ILsl_nat (kinfo, k) -> + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> let extra = (kinfo, k) in (ilsl_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | ILsr_nat (kinfo, k) -> + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> let extra = (kinfo, k) in (ilsr_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | IFailwith (_, kloc, tv) -> + | (IFailwith (_, kloc, tv), _, _) -> let {ifailwith} = ifailwith in (ifailwith [@ocaml.tailcall]) (Some logger) g gas kloc tv accu - | IExec (_, k) -> + | (IExec (_, k), _, (stack : _ lambda * _)) -> (iexec [@ocaml.tailcall]) (Some logger) g gas k ks accu stack | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack [@@inline] -and klog : +and[@coq_axiom_with_reason "we ignore the logging operations"] klog : type a s r f. logger -> outdated_context * step_constants -> @@ -1589,51 +1866,52 @@ and klog : (match ks with KLog _ -> () | _ -> log_control logger ks) ; let enable_log ki = log_kinstr logger ki in let mk k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match ks with - | KCons (ki, ks') -> + match[@coq_match_gadt] (ks, accu, stack) with + | (KCons (ki, ks'), _, _) -> let log = enable_log ki in let ks = mk ks' in (step [@ocaml.tailcall]) g gas log ks accu stack - | KNil -> (next [@ocaml.tailcall]) g gas ks accu stack - | KLoop_in (ki, ks') -> + | (KNil, _, _) -> (next [@ocaml.tailcall]) g gas ks accu stack + | (KLoop_in (ki, ks'), (accu : bool), (stack : _ * _)) -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks') -> + | (KReturn (stack', ks'), _, _) -> let ks' = mk ks' in let ks = KReturn (stack', ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | (KMap_head (f, ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks (f accu) stack + | (KLoop_in_left (ki, ks'), (accu : _ union), _) -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks') -> + | (KUndip (x, ks'), _, _) -> let ks' = mk ks' in let ks = KUndip (x, ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KIter (body, xs, ks') -> + | (KIter (body, xs, ks'), _, _) -> let ks' = mk ks' in let body = enable_log body in (kiter [@ocaml.tailcall]) mk g gas (body, xs) ks' accu stack - | KList_enter_body (body, xs, ys, len, ks') -> + | (KList_enter_body (body, xs, ys, len, ks'), _, _) -> let ks' = mk ks' in let extra = (body, xs, ys, len) in (klist_enter [@ocaml.tailcall]) mk g gas extra ks' accu stack - | KList_exit_body (body, xs, ys, len, ks') -> + | (KList_exit_body (body, xs, ys, len, ks'), _, (stack : _ * _)) -> let ks' = mk ks' in let extra = (body, xs, ys, len) in (klist_exit [@ocaml.tailcall]) mk g gas extra ks' accu stack - | KMap_enter_body (body, xs, ys, ks') -> + | (KMap_enter_body (body, xs, ys, ks'), _, _) -> let ks' = mk ks' in (kmap_enter [@ocaml.tailcall]) mk g gas (body, xs, ys) ks' accu stack - | KMap_exit_body (body, xs, ys, yk, ks') -> + | (KMap_exit_body (body, xs, ys, yk, ks'), _, (stack : _ * _)) -> let ks' = mk ks' in (kmap_exit [@ocaml.tailcall]) mk g gas (body, xs, ys, yk) ks' accu stack - | KView_exit (orig_step_constants, ks') -> + | (KView_exit (orig_step_constants, ks'), _, _) -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks' accu stack - | KLog (_, _) -> + | (KLog (_, _), _, _) -> (* This case should never happen. *) (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -1678,7 +1956,7 @@ let kstep logger ctxt step_constants kinstr accu stack = let internal_step ctxt step_constants gas kinstr accu stack = step (ctxt, step_constants) gas kinstr KNil accu stack -let step logger ctxt step_constants descr stack = +let test_step logger ctxt step_constants descr stack = step_descr ~log_now:false logger (ctxt, step_constants) descr stack (* @@ -1710,7 +1988,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty) >>?= fun (res, ctxt) -> res >>?= fun Eq -> let parsed_arg : a = parsed_arg in - return (parsed_arg, ctxt)) + return ((parsed_arg [@coq_cast]), ctxt)) >>=? fun (entrypoint_arg, ctxt) -> return (construct entrypoint_arg, ctxt) type execution_result = { @@ -1732,25 +2010,31 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ~legacy:true ~allow_forged_in_storage:true | Some ex_script -> return (ex_script, ctxt)) - >>=? fun ( Ex_script - (Script - { - code_size; - code; - arg_type; - storage = old_storage; - storage_type; - entrypoints; - views; - }), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + code_size; + code; + arg_type; + storage = old_storage; + storage_type; + entrypoints; + views; + }), + ctxt ) -> Gas_monad.run ctxt (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) >>?= fun (r, ctxt) -> - record_trace (Bad_contract_parameter step_constants.self) r - >>?= fun (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) - -> + record_trace + (Bad_contract_parameter step_constants.self) + (r [@coq_type_annotation]) + >>?= fun [@coq_match_gadt] (Ex_ty_cstr + { + ty = entrypoint_ty; + construct; + original_type_expr = _; + }) -> trace (Bad_contract_parameter step_constants.self) (lift_execution_arg ctxt ~internal entrypoint_ty construct arg) @@ -1774,7 +2058,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal >>=? fun (storage, lazy_storage_diff, ctxt) -> trace Cannot_serialize_storage - ( unparse_data ctxt mode storage_type storage + ( (unparse_data [@coq_type_annotation]) ctxt mode storage_type storage >>=? fun (unparsed_storage, ctxt) -> Lwt.return ( Gas.consume ctxt (Script.strip_locations_cost unparsed_storage) diff --git a/src/proto_013_PtJakart/lib_protocol/script_interpreter.mli b/src/proto_013_PtJakart/lib_protocol/script_interpreter.mli index c57869e469d08..3d23a61529efd 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_interpreter.mli +++ b/src/proto_013_PtJakart/lib_protocol/script_interpreter.mli @@ -70,7 +70,7 @@ type step_constants = Script_typed_ir.step_constants = { level : Script_int.n Script_int.num; } -val step : +val test_step : logger option -> context -> Script_typed_ir.step_constants -> diff --git a/src/proto_013_PtJakart/lib_protocol/script_interpreter_defs.ml b/src/proto_013_PtJakart/lib_protocol/script_interpreter_defs.ml index 12fc3baf22489..f225e77368bd2 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_interpreter_defs.ml @@ -54,291 +54,270 @@ 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 + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | (IList_map _, (list : _ boxed_list), _) -> Interp_costs.list_map list + | (IList_iter _, (list : _ boxed_list), _) -> Interp_costs.list_iter list + | (ISet_iter _, (set : _ set), _) -> Interp_costs.set_iter set + | (ISet_mem _, v, (stack : _ * _)) -> + let (set, _) = stack in Interp_costs.set_mem v set - | ISet_update _ -> - let v = accu and (_, (set, _)) = stack in + | (ISet_update _, v, (stack : _ * (_ * _))) -> + let (_, (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 + | (IMap_map _, (map : (_, _) map), _) -> Interp_costs.map_map map + | (IMap_iter _, (map : (_, _) map), _) -> Interp_costs.map_iter map + | (IMap_mem _, v, (stack : (a, _) map * _)) -> + let (map, _) = stack in Interp_costs.map_mem v map - | IMap_get _ -> - let v = accu and (map, _) = stack in + | (IMap_get _, v, (stack : (a, _) map * _)) -> + let (map, _) = stack in Interp_costs.map_get v map - | IMap_update _ -> - let k = accu and (_, (map, _)) = stack in + | (IMap_update _, k, (stack : _ * ((a, _) map * _))) -> + let (_, (map, _)) = stack in Interp_costs.map_update k map - | IMap_get_and_update _ -> - let k = accu and (_, (map, _)) = stack in + | (IMap_get_and_update _, k, (stack : _ * ((a, _) map * _))) -> + let (_, (map, _)) = stack in Interp_costs.map_get_and_update k map - | IBig_map_mem _ -> + | (IBig_map_mem _, _, (stack : (a, _) big_map * _)) -> let (Big_map map, _) = stack in Interp_costs.big_map_mem map.diff - | IBig_map_get _ -> + | (IBig_map_get _, _, (stack : (a, _) big_map * _)) -> let (Big_map map, _) = stack in Interp_costs.big_map_get map.diff - | IBig_map_update _ -> + | (IBig_map_update _, _, (stack : _ * ((a, _) big_map * _))) -> let (_, (Big_map map, _)) = stack in Interp_costs.big_map_update map.diff - | IBig_map_get_and_update _ -> + | (IBig_map_get_and_update _, _, (stack : _ * ((a, _) big_map * _))) -> 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 + | ( IAdd_seconds_to_timestamp _, + (n : _ Script_int.num), + (stack : Script_timestamp.t * _) ) -> + let (t, _) = stack in Interp_costs.add_seconds_timestamp n t - | IAdd_timestamp_to_seconds _ -> - let t = accu and (n, _) = stack in + | ( IAdd_timestamp_to_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let (n, _) = stack in Interp_costs.add_timestamp_seconds t n - | ISub_timestamp_seconds _ -> - let t = accu and (n, _) = stack in + | ( ISub_timestamp_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let (n, _) = stack in Interp_costs.sub_timestamp_seconds t n - | IDiff_timestamps _ -> - let t1 = accu and (t2, _) = stack in + | ( IDiff_timestamps _, + (t1 : Script_timestamp.t), + (stack : Script_timestamp.t * _) ) -> + let (t2, _) = stack in Interp_costs.diff_timestamps t1 t2 - | IConcat_string_pair _ -> - let x = accu and (y, _) = stack in + | (IConcat_string_pair _, (x : Script_string.t), (stack : Script_string.t * _)) + -> + let (y, _) = stack in Interp_costs.concat_string_pair x y - | IConcat_string _ -> - let ss = accu in + | (IConcat_string _, (ss : _ boxed_list), _) -> Interp_costs.concat_string_precheck ss - | ISlice_string _ -> - let _offset = accu in + | ( ISlice_string _, + _offset, + (stack : _ Script_int.num * (Script_string.t * _)) ) -> let (_length, (s, _)) = stack in Interp_costs.slice_string s - | IConcat_bytes_pair _ -> - let x = accu and (y, _) = stack in + | (IConcat_bytes_pair _, (x : bytes), (stack : bytes * _)) -> + let (y, _) = stack in Interp_costs.concat_bytes_pair x y - | IConcat_bytes _ -> - let ss = accu in + | (IConcat_bytes _, (ss : _ boxed_list), _) -> Interp_costs.concat_string_precheck ss - | ISlice_bytes _ -> + | (ISlice_bytes _, _, (stack : _ * (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 + | (IMul_teznat _, _, _) -> Interp_costs.mul_teznat + | (IMul_nattez _, _, _) -> Interp_costs.mul_nattez + | (IAbs_int _, (x : _ Script_int.num), _) -> Interp_costs.abs_int x + | (INeg _, (x : _ Script_int.num), _) -> Interp_costs.neg x + | (IAdd_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.add_int x y - | IAdd_nat _ -> - let x = accu and (y, _) = stack in + | (IAdd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.add_nat x y - | ISub_int _ -> - let x = accu and (y, _) = stack in + | (ISub_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.sub_int x y - | IMul_int _ -> - let x = accu and (y, _) = stack in + | (IMul_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.mul_int x y - | IMul_nat _ -> - let x = accu and (y, _) = stack in + | (IMul_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.mul_nat x y - | IEdiv_teznat _ -> - let x = accu and (y, _) = stack in + | (IEdiv_teznat _, x, (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.ediv_teznat x y - | IEdiv_int _ -> - let x = accu and (y, _) = stack in + | (IEdiv_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.ediv_int x y - | IEdiv_nat _ -> - let x = accu and (y, _) = stack in + | (IEdiv_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (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 + | (ILsl_nat _, (x : _ Script_int.num), _) -> Interp_costs.lsl_nat x + | (ILsr_nat _, (x : _ Script_int.num), _) -> Interp_costs.lsr_nat x + | (IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.or_nat x y - | IAnd_nat _ -> - let x = accu and (y, _) = stack in + | (IAnd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.and_nat x y - | IAnd_int_nat _ -> - let x = accu and (y, _) = stack in + | (IAnd_int_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.and_int_nat x y - | IXor_nat _ -> - let x = accu and (y, _) = stack in + | (IXor_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (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 + | (INot_int _, (x : _ Script_int.num), _) -> Interp_costs.not_int x + | (ICompare (_, ty, _), a, (stack : a * _)) -> + let (b, _) = stack in Interp_costs.compare ty a b - | ICheck_signature _ -> - let key = accu and (_, (message, _)) = stack in + | (ICheck_signature _, (key : public_key), (stack : _ * (bytes * _))) -> + let (_, (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 + | (IHash_key _, (pk : public_key), _) -> Interp_costs.hash_key pk + | (IBlake2b _, (bytes : bytes), _) -> Interp_costs.blake2b bytes + | (ISha256 _, (bytes : bytes), _) -> Interp_costs.sha256 bytes + | (ISha512 _, (bytes : bytes), _) -> Interp_costs.sha512 bytes + | (IKeccak _, (bytes : bytes), _) -> Interp_costs.keccak bytes + | (ISha3 _, (bytes : bytes), _) -> Interp_costs.sha3 bytes + | (IPairing_check_bls12_381 _, (pairs : _ boxed_list), _) -> Interp_costs.pairing_check_bls12_381 pairs - | ISapling_verify_update _ -> + | (ISapling_verify_update _, (accu : Sapling_repr.transaction), _) -> 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 _ -> + | ( ISapling_verify_update_deprecated _, + (accu : Sapling_repr.legacy_transaction), + _ ) -> 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 ticket = accu and ((amount_a, amount_b), _) = stack in + | (ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _)) -> + let ticket = accu in + let ((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 + | (IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _) -> + let (ticket_a, ticket_b) = ticket_a_b 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 _ -> 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 _ -> + | (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 _, _, _) -> 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 _, (accu : bytes), _) -> 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 _ -> + | (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 _, _, _) -> . + | (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 _, (accu : _ Script_int.num), _) -> let z = accu in Interp_costs.mul_bls12_381_fr_z z - | IMul_bls12_381_z_fr _ -> + | (IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _)) -> 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 - | IOpen_chest _ -> - let _chest_key = accu and (chest, (time, _)) = stack in + | (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 + | ( IOpen_chest _, + _chest_key, + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> + let (chest, (time, _)) = stack in Interp_costs.open_chest ~chest ~time:(Alpha_context.Script_int.to_zint time) - | ILog _ -> Gas.free + | (ILog _, _, _) -> Gas.free [@@ocaml.inline always] - [@@coq_axiom_with_reason "unreachable expression `.` not handled"] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = fun ks -> @@ -444,7 +423,7 @@ let id x = x [@@inline] (* The following function pops n elements from the stack and push their reintroduction in the continuations stack. *) -let rec kundip : +let[@coq_struct "w_value"] 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 -> @@ -452,53 +431,58 @@ let rec kundip : (d, w, b, t) kinstr -> a * s * (e, z, b, t) kinstr = fun w accu stack k -> - match w with - | KPrefix (kinfo, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | (KPrefix (kinfo, w), _, (stack : _ * _)) -> let k = IConst (kinfo, accu, k) in let (accu, stack) = stack in kundip w accu stack k - | KRest -> (accu, stack, k) + | (KRest, (accu : a), (stack : s)) -> (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) -> - let loc = Micheline.dummy_location in - unparse_ty ~loc 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) 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); - } - in - IConst (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); - } - in - let full_expr = - Micheline.Seq - ( loc, - [ - Prim (loc, I_PUSH, [ty_expr; const_expr], []); - Prim (loc, I_PAIR, [], []); - expr; - ] ) - in - let lam' = Lam (full_descr, full_expr) in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in - return (lam', ctxt, gas) + match[@coq_match_with_default] descr.kbef with + | Item_t (full_arg_ty, _) -> ( + let ctxt = update_context gas ctxt in + unparse_data ctxt Optimized capture_ty capture + >>=? fun (const_expr, ctxt) -> + let loc = Micheline.dummy_location in + unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + match[@coq_match_with_default] 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 = + (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); + } + in + IConst + (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); + } + in + let full_expr = + Micheline.Seq + ( loc, + [ + Prim (loc, I_PUSH, [ty_expr; const_expr], []); + Prim (loc, I_PAIR, [], []); + expr; + ] ) + in + let lam' = Lam (full_descr, full_expr) in + let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + return (lam', ctxt, gas)) (* [transfer (ctxt, sc) gas tez parameters_ty parameters destination entrypoint] creates an operation that transfers an amount of [tez] to @@ -655,7 +639,7 @@ let unpack ctxt ~ty ~bytes = 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 : +let[@coq_struct "n_value"] 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 -> @@ -663,11 +647,11 @@ let rec interp_stack_prefix_preserving_operation : u -> (d * w) * result = fun f n accu stk -> - match (n, stk) with - | (KPrefix (_, n), rest) -> + match[@coq_match_gadt_with_result] (n, accu, 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 + | (KRest, (accu : a), (v : s)) -> f accu v (* diff --git a/src/proto_013_PtJakart/lib_protocol/script_ir_annot.ml b/src/proto_013_PtJakart/lib_protocol/script_ir_annot.ml index a0cb334ce1416..219aa6956933d 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_ir_annot.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_ir_annot.ml @@ -42,7 +42,7 @@ let error_unexpected_annot loc annot = (* Check that the predicate p holds on all s.[k] for k >= i *) let string_iter p s i = let len = String.length s in - let rec aux i = + let[@coq_struct "i_value"] rec aux i = if Compare.Int.(i >= len) then Result.return_unit else p s.[i] >>? fun () -> aux (i + 1) in diff --git a/src/proto_013_PtJakart/lib_protocol/script_ir_translator.ml b/src/proto_013_PtJakart/lib_protocol/script_ir_translator.ml index 1c99eb32003dd..f124eb0061394 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_ir_translator.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_ir_translator.ml @@ -162,7 +162,8 @@ let check_kind kinds expr = the end of the file. *) let rec ty_of_comparable_ty : - type a. a comparable_ty -> (a, Dependent_bool.yes) ty = function + type a. a comparable_ty -> (a, Dependent_bool.yes) ty = + function[@coq_match_with_default] | Unit_t -> Unit_t | Never_t -> Never_t | Int_t -> Int_t @@ -186,7 +187,7 @@ let rec ty_of_comparable_ty : let rec unparse_comparable_ty_uncarbonated : type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = - fun ~loc -> function + fun ~loc -> function[@coq_match_with_default] | Unit_t -> Prim (loc, T_unit, [], []) | Never_t -> Prim (loc, T_never, [], []) | Int_t -> Prim (loc, T_int, [], []) @@ -334,7 +335,7 @@ let serialize_ty_for_error ty = *) unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations -let[@coq_axiom_with_reason "gadt"] rec comparable_ty_of_ty : +let rec comparable_ty_of_ty : type a ac. context -> Script.location -> @@ -596,7 +597,7 @@ let comparable_comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : +let[@coq_struct "ty"] rec unparse_comparable_data : type a loc. loc:loc -> context -> @@ -605,42 +606,47 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : a -> (loc Script.michelson_node * context) tzresult Lwt.t = fun ~loc ctxt mode ty a -> - (* No need for stack_depth here. Unlike [unparse_data], - [unparse_comparable_data] doesn't call [unparse_code]. + (* No need for stack_depth here. Unlike [unparse_data_aux], + [unparse_comparable_data] doesn't call [unparse_code_aux]. The stack depth is bounded by the type depth, currently bounded by 1000 (michelson_maximum_type_size). *) Gas.consume ctxt Unparse_costs.unparse_data_cycle (* We could have a smaller cost but let's keep it consistent with - [unparse_data] for now. *) + [unparse_data_aux] for now. *) >>?= fun ctxt -> - match (ty, a) with - | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, address) -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v + | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v + | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v + | (String_t, (s : Script_string.t)) -> + Lwt.return @@ unparse_string ~loc ctxt s + | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b + | (Timestamp_t, (t : Script_timestamp.t)) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | (Address_t, (address : address)) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Chain_id_t, chain_id) -> + | (Signature_t, (s : signature)) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | (Key_hash_t, (k : public_key_hash)) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | (Chain_id_t, (chain_id : Script_chain_id.t)) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Pair_t (tl, tr, _, YesYes), pair) -> + | (Pair_t (tl, tr, _, YesYes), (pair : _ * _)) -> let r_witness = comparable_comb_witness2 tr in let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | (Union_t (tl, tr, _, YesYes), v) -> + | (Union_t (tl, tr, _, YesYes), (v : _ union)) -> let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, Yes), v) -> + | (Option_t (t, _, Yes), (v : _ option)) -> let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v | (Never_t, _) -> . @@ -674,7 +680,8 @@ let hash_comparable_data ctxt ty data = All comparable types are dupable, this function exists only to not forget checking this property when adding new types. *) -let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = + function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ -> @@ -783,7 +790,7 @@ let rec comparable_ty_eq : let not_equal () = of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ -791,7 +798,7 @@ let rec comparable_ty_eq : (ty_of_comparable_ty ta) (ty_of_comparable_ty tb)) in - match (ta, tb) with + match[@coq_match_with_default] (ta, tb) with | (Unit_t, Unit_t) -> return (Eq : (ta comparable_ty, tb comparable_ty) eq) | (Unit_t, _) -> not_equal () | (Never_t, Never_t) -> return Eq @@ -852,7 +859,7 @@ let memo_size_eq : if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) @@ -875,27 +882,28 @@ let ty_eq : let memo_size_eq ms1 ms2 = Gas_monad.of_result (memo_size_eq ~error_details ms1 ms2) in - let rec help : - type ta tac tb tbc. - (ta, tac) ty -> - (tb, tbc) ty -> - (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = - fun ty1 ty2 -> - help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun () -> - default_ty_eq_error ty1 ty2) - and help0 : + let rec help0 : type ta tac tb tbc. (ta, tac) ty -> (tb, tbc) ty -> (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = fun ty1 ty2 -> + let help : + type ta tac tb tbc. + (ta, tac) ty -> + (tb, tbc) ty -> + (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = + fun ty1 ty2 -> + help0 ty1 ty2 + |> Gas_monad.record_trace_eval ~error_details (fun () -> + default_ty_eq_error ty1 ty2) + in let open Gas_monad.Syntax in let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in let not_equal () = Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ default_ty_eq_error ty1 ty2) in @@ -1013,8 +1021,9 @@ let ty_eq : | (Chest_key_t, Chest_key_t) -> return Eq | (Chest_key_t, _) -> not_equal () in - help ty1 ty2 - [@@coq_axiom_with_reason "non-top-level mutual recursion"] + help0 ty1 ty2 + |> Gas_monad.record_trace_eval ~error_details (fun () -> + default_ty_eq_error ty1 ty2) (* Same as ty_eq but for stacks. A single error monad is used here because there is no need to @@ -1047,6 +1056,7 @@ type ('a, 's) judgement = descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr; } -> ('a, 's) judgement +[@@coq_force_gadt] (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) @@ -1099,7 +1109,7 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -let[@coq_struct "ty"] rec parse_comparable_ty : +let[@coq_struct "ty"] rec parse_comparable_ty_aux : stack_depth:int -> context -> Script.node -> @@ -1171,25 +1181,25 @@ let[@coq_struct "ty"] rec parse_comparable_ty : (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, right, []))) >>? fun right -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right >>? fun (Ex_comparable_ty right, ctxt) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left >>? fun (Ex_comparable_ty left, ctxt) -> pair_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, T_or, [left; right], annot) -> check_type_annot loc annot >>? fun () -> remove_field_annot left >>? fun left -> remove_field_annot right >>? fun right -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right >>? fun (Ex_comparable_ty right, ctxt) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left >>? fun (Ex_comparable_ty left, ctxt) -> union_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, ((T_pair | T_or) as prim), l, _) -> error (Invalid_arity (loc, prim, 2, List.length l)) | Prim (loc, T_option, [t], annot) -> check_type_annot loc annot >>? fun () -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>? fun (Ex_comparable_ty t, ctxt) -> option_key loc t >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, T_option, l, _) -> @@ -1235,21 +1245,21 @@ type ex_parameter_ty_and_entrypoints_node = } -> ex_parameter_ty_and_entrypoints_node -(** [parse_ty] can be used to parse regular types as well as parameter types +(** [parse_ty_aux] can be used to parse regular types as well as parameter types together with their entrypoints. - In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will + In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty_aux] will return an [ex_ty]. - In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return - an [ex_parameter_ty_and_entrypoints_node]. + In the second case, use [~ret:Parse_entrypoints], [parse_ty_aux] will return + an [ex_parameter_ty_and_entrypoints]. *) type ('ret, 'name) parse_ty_ret = | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty : +let[@coq_struct "node_value"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -1275,11 +1285,11 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty error Typechecking_too_many_recursive_calls else (match ret with - | Don't_parse_entrypoints -> ok (node, (() : name)) + | Don't_parse_entrypoints -> ok (node, None) | Parse_entrypoints -> extract_entrypoint_annot node) >>? fun (node, name) -> let return ctxt ty : ret * context = - match ret with + match[@coq_match_gadt_with_result] ret with | Don't_parse_entrypoints -> (Ex_ty ty, ctxt) | Parse_entrypoints -> let at_node = @@ -1342,7 +1352,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1354,7 +1364,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> remove_field_annot utl >>? fun utl -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1371,7 +1381,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, utr, []))) >>? fun utr -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1391,7 +1401,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty remove_field_annot utr >|? fun utr -> (utl, utr) | Parse_entrypoints -> ok (utl, utr)) >>? fun (utl, utr) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1402,7 +1412,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1414,12 +1424,20 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty utr >>? fun (parsed_r, ctxt) -> check_type_annot loc annot >>? fun () -> - match ret with - | Don't_parse_entrypoints -> + match[@coq_match_gadt_with_result] + ( ret, + (parsed_l [@coq_type_annotation]), + (parsed_r [@coq_type_annotation]) ) + with + | (Don't_parse_entrypoints, (parsed_l : ex_ty), (parsed_r : ex_ty)) -> let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt) - | Parse_entrypoints -> + (* | Parse_entrypoints -> + * let (Ex_parameter_ty_and_entrypoints_node *) + | ( Parse_entrypoints, + (parsed_l : ex_parameter_ty_and_entrypoints_node), + (parsed_r : ex_parameter_ty_and_entrypoints_node) ) -> let (Ex_parameter_ty_and_entrypoints_node {arg_type = tl; entrypoints = left}) = parsed_l @@ -1438,9 +1456,9 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) ) | Prim (loc, T_lambda, [uta; utr], annot) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> return ctxt ty @@ -1451,7 +1469,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_composed_type_annot loc annot >>? fun () -> ok ut else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1464,7 +1482,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty >>? fun (Ex_ty t, ctxt) -> option_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_list, [ut], annot) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1479,20 +1497,20 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty list_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> return ctxt ty else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1589,7 +1607,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty T_tx_rollup_l2_address; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty : +and[@coq_mutual_as_notation] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -1598,41 +1616,40 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:false - ~allow_contract:true - ~allow_ticket:true + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:true + ~allow_ticket:true [@coq_type_annotation]) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty - : +and[@coq_mutual_as_notation] parse_any_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_ty - ctxt ~stack_depth ~legacy big_map_loc args map_annot = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + ~ret:Don't_parse_entrypoints [@coq_type_annotation]) + +and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc + args map_annot = Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1643,21 +1660,21 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty - ctxt ~stack_depth ~legacy value_ty = - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:legacy - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - value_ty - -let parse_packable_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) +and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth + ~legacy value_ty = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + ~ret:Don't_parse_entrypoints + value_ty [@coq_type_annotation]) + +let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1672,7 +1689,7 @@ let parse_packable_ty ctxt ~stack_depth ~legacy node = node let parse_view_input_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1684,7 +1701,7 @@ let parse_view_input_ty ctxt ~stack_depth ~legacy node = node let parse_view_output_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1696,7 +1713,7 @@ let parse_view_output_ty ctxt ~stack_depth ~legacy node = node let parse_normal_storage_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1810,6 +1827,7 @@ type ('arg, 'storage) code = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script @@ -1823,6 +1841,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view +[@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) map @@ -1867,16 +1886,19 @@ type 'before comb_get_proof_argument = | Comb_get_proof_argument : ('before, 'after) comb_get_gadt_witness * ('after, _) ty -> 'before comb_get_proof_argument +[@@coq_force_gadt] type ('rest, 'before) comb_set_proof_argument = | Comb_set_proof_argument : ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty -> ('rest, 'before) comb_set_proof_argument +[@@coq_force_gadt] type 'before dup_n_proof_argument = | Dup_n_proof_argument : ('before, 'a) dup_n_gadt_witness * ('a, _) ty -> 'before dup_n_proof_argument +[@@coq_force_gadt] let rec make_dug_proof_argument : type a s x xc. @@ -1946,7 +1968,7 @@ let find_entrypoint (type full fullc error_trace) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let rec find_entrypoint : + let[@coq_struct "ty"] rec find_entrypoint : type t tc. (t, tc) ty -> t entrypoints_node -> @@ -1954,27 +1976,35 @@ let find_entrypoint (type full fullc error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in - match (ty, entrypoints) with + match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with | (_, {at_node = Some {name; original_type_expr}; _}) when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) - | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) - -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function - | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> - return - (Ex_ty_cstr - { - ty; - construct = (fun e -> L (construct e)); - original_type_expr; - }) - | Error () -> - let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - find_entrypoint tr right entrypoint - in - Ex_ty_cstr - {ty; construct = (fun e -> R (construct e)); original_type_expr}) + | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) -> + Gas_monad.bind_recover + (find_entrypoint tl left entrypoint) + (function [@coq_match_gadt] + | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> + return + (Ex_ty_cstr + { + ty; + construct = (fun e -> L (construct e)); + original_type_expr; + }) + | Error () -> ( + let+ x = + (find_entrypoint tr right entrypoint [@coq_type_annotation]) + in + match[@coq_match_gadt] x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr + { + ty; + construct = (fun e -> R (construct e)); + original_type_expr; + })) + [@coq_cast] | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -1987,7 +2017,7 @@ let find_entrypoint (type full fullc error_trace) else Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) @@ -1996,7 +2026,13 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) entrypoints entrypoint loc : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let* res = find_entrypoint ~error_details full entrypoints entrypoint in + let* res = + (find_entrypoint + ~error_details + full + entrypoints + entrypoint [@coq_type_annotation]) + in match res with | Ex_ty_cstr {ty; _} -> ( match entrypoints.root.at_node with @@ -2074,14 +2110,14 @@ type ex_parameter_ty_and_entrypoints = } -> ex_parameter_ty_and_entrypoints -let parse_parameter_ty_and_entrypoints : +let parse_parameter_ty_and_entrypoints_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_parameter_ty_and_entrypoints * context) tzresult = fun ctxt ~stack_depth ~legacy node -> - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2095,7 +2131,8 @@ let parse_parameter_ty_and_entrypoints : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints +let parse_passable_ty_aux = + parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2434,7 +2471,7 @@ let comparable_comb_witness1 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data : +let[@coq_struct "ty"] rec parse_comparable_data : type a. ?type_logger:type_logger -> context -> @@ -2442,7 +2479,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data : Script.node -> (a * context) tzresult Lwt.t = fun ?type_logger ctxt ty script_data -> - (* No need for stack_depth here. Unlike [parse_data], + (* No need for stack_depth here. Unlike [parse_data_aux], [parse_comparable_data] doesn't call [parse_returning]. The stack depth is bounded by the type depth, bounded by 1024. *) let parse_data_error () = @@ -2453,11 +2490,13 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data : let traced body = trace_eval parse_data_error body in Gas.consume ctxt Typecheck_costs.parse_data_cycle (* We could have a smaller cost but let's keep it consistent with - [parse_data] for now. *) + [parse_data_aux] for now. *) >>?= fun ctxt -> let legacy = false in - match (ty, script_data) with + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (ty, script_data) + with | (Unit_t, expr) -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -2504,7 +2543,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = (* Some values, such as operations, tickets, or big map ids, are used only internally and are not allowed to be forged by users. - In [parse_data], [allow_forged] should be [false] for: + In [parse_data_aux], [allow_forged] should be [false] for: - PUSH - UNPACK - user-provided script parameters @@ -2514,7 +2553,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = - storage after origination *) -let[@coq_axiom_with_reason "gadt"] rec parse_data : +let[@coq_struct "ctxt"] rec parse_data_aux : type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2530,7 +2569,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : if Compare.Int.(stack_depth > 10_000) then fail Typechecking_too_many_recursive_calls else - parse_data + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -2658,7 +2697,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : |> traced >|=? fun (_, map, ctxt) -> (map, ctxt) in - match (ty, script_data) with + match[@coq_match_gadt_with_result] (ty, script_data) with | (Unit_t, expr) -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -2689,7 +2728,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in - parse_contract + parse_contract_aux ~stack_depth:(stack_depth + 1) ctxt loc @@ -2729,7 +2768,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : tr script_instr | (Lambda_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | (Option_t (t, _, _), expr) -> let parse_v ctxt v = @@ -2746,7 +2786,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : items (Script_list.empty, ctxt) | (List_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | (Ticket_t (t, _ty_name), expr) -> if allow_forged then @@ -2754,7 +2795,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : parse_comparable_data ?type_logger ctxt ty expr >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) -> match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Contract ticketer -> + return + ( {ticketer; contents = contents [@coq_type_annotation]; amount}, + ctxt ) | Tx_rollup _ -> fail (Unexpected_ticket_owner destination) else traced_fail (Unexpected_forged_value (location expr)) (* Sets *) @@ -2789,16 +2833,28 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : vs >|=? fun (_, set, ctxt) -> (set, ctxt) | (Set_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) -> - parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) + ((parse_items [@coq_type_annotation]) + ?type_logger + ctxt + expr + tk + tv + vs + (fun x -> x) + : (_ map * _) tzresult Lwt.t) | (Map_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) | (Big_map_t (tk, tv, _ty_name), expr) -> (match expr with | Int (loc, id) -> - return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + return + (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + [@coq_type_annotation] | Seq (_, vs) -> parse_big_map_items ?type_logger ctxt expr tk tv vs (fun x -> Some x) >|=? fun (diff, ctxt) -> (None, diff, ctxt) @@ -2826,12 +2882,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | (_, None) -> traced_fail (Invalid_big_map (loc, id)) | (ctxt, Some (btk, btv)) -> Lwt.return - ( parse_comparable_ty + ( parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2857,14 +2913,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | (Bls12_381_g1_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Bls12_381_g2_t, Bytes (_, bs)) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | (Bls12_381_g2_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Bls12_381_fr_t, Bytes (_, bs)) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with @@ -2874,7 +2932,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) | (Bls12_381_fr_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. @@ -2896,7 +2955,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | (Sapling_transaction_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes)) -> ( match Data_encoding.Binary.of_bytes_opt @@ -2915,7 +2975,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | (Sapling_transaction_deprecated_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Sapling_state_t memo_size, Int (loc, id)) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2929,11 +2990,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) | (Sapling_state_t memo_size, Seq (_, [])) -> - return (Sapling.empty_state ~memo_size (), ctxt) + ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt) + : (Sapling.state * _) tzresult Lwt.t) | (Sapling_state_t _, expr) -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) - traced_fail + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | (Chest_key_t, Bytes (_, bytes)) -> ( @@ -2946,7 +3008,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) | (Chest_key_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Chest_t, Bytes (_, bytes)) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> @@ -2956,9 +3019,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) | (Chest_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and parse_view : +and[@coq_struct "ctxt"] parse_view : type storage storagec. ?type_logger:type_logger -> context -> @@ -2982,7 +3046,7 @@ and parse_view : (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) >>?= fun (Ex_ty output_ty, ctxt) -> pair_t input_ty_loc input_ty storage_type >>?= fun (Ty_ex_c pair_ty) -> - parse_instr + parse_instr_aux ?type_logger ~stack_depth:0 Tc_context.view @@ -3022,7 +3086,7 @@ and parse_view : ctxt ) | _ -> error (ill_type_view loc aft ())) -and parse_views : +and[@coq_struct "type_logger_value"] parse_views : type storage storagec. ?type_logger:type_logger -> context -> @@ -3039,7 +3103,7 @@ and parse_views : in Script_map.map_es_in_context aux ctxt views -and[@coq_axiom_with_reason "gadt"] parse_returning : +and[@coq_mutual_as_notation] parse_returning : type arg argc ret retc. ?type_logger:type_logger -> stack_depth:int -> @@ -3051,7 +3115,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ?type_logger ~stack_depth tc_context ctxt ~legacy arg ret script_instr -> - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -3081,7 +3145,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_axiom_with_reason "gadt"] parse_instr : +and[@coq_struct "ctxt"] parse_instr_aux : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -3127,7 +3191,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : if Compare.Int.(stack_depth > 10000) then fail Typechecking_too_many_recursive_calls else - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -3259,9 +3323,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc swap stack_ty | (Prim (loc, I_PUSH, [t; d], annot), stack) -> check_var_annot loc annot >>?= fun () -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t - >>?= fun (Ex_ty t, ctxt) -> - parse_data + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -3270,7 +3334,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : t d >>=? fun (v, ctxt) -> - let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in + let const = + {apply = (fun kinfo k -> IConst (kinfo, (v [@coq_type_annotation]), k))} + in typed ctxt loc const (Item_t (t, stack)) | (Prim (loc, I_UNIT, [], annot), stack) -> check_var_type_annot loc annot >>?= fun () -> @@ -3282,7 +3348,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | (Prim (loc, I_NONE, [t], annot), stack) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in @@ -3366,8 +3432,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ok (Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty))) | (n, Item_t (a_ty, tl_ty)) -> make_proof_argument (n - 1) tl_ty - >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) - -> + >>? fun [@coq_match_with_default] (Comb_proof_argument + ( comb_witness, + Item_t (b_ty, tl_ty') )) -> pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) -> Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) | _ -> @@ -3384,7 +3451,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc comb after_ty | (Prim (loc, I_UNPAIR, [n], annot), stack_ty) -> error_unexpected_annot loc annot >>?= fun () -> - let rec make_proof_argument : + let[@coq_struct "n_value"] rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) uncomb_proof_argument tzresult = fun n stack_ty -> @@ -3447,7 +3514,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc cdr (Item_t (b, rest)) (* unions *) | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest)) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in @@ -3455,7 +3522,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest)) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in @@ -3500,7 +3567,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) | (Prim (loc, I_NIL, [t], annot), stack) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in @@ -3621,7 +3688,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) (* sets *) | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in @@ -3684,9 +3751,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in @@ -3817,9 +3884,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = @@ -4060,9 +4127,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -4509,7 +4576,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (* annotations *) | (Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> Gas_monad.run ctxt @@ ty_eq ~error_details:Informative loc cast_t t >>?= fun (eq, ctxt) -> @@ -4534,7 +4601,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest)) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> @@ -4548,7 +4615,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (address_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest)) -> - parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> option_t loc contract_ty >>?= fun res_ty -> @@ -4607,11 +4674,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - parse_toplevel ctxt ~legacy canonical_code + parse_toplevel_aux ctxt ~legacy canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) - (parse_parameter_ty_and_entrypoints + (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -4640,10 +4707,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : arg_type_full ret_type_full code_field) - >>=? fun ( Lam - ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, - _ ), - ctxt ) -> + >>=? fun [@coq_match_with_default] ( Lam + ( { + kbef = Item_t (arg, Bot_t); + kaft = Item_t (ret, Bot_t); + _; + }, + _ ), + ctxt ) -> let views_result = parse_views ctxt ?type_logger ~legacy storage_type views in @@ -4723,7 +4794,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint -> let open Tc_context in - match tc_context.callsite with + match[@coq_match_gadt] tc_context.callsite with | _ when is_in_lambda tc_context -> error (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim)) @@ -4736,11 +4807,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt - @@ find_entrypoint - ~error_details:Informative - param_type - entrypoints - entrypoint + @@ (find_entrypoint + ~error_details:Informative + param_type + entrypoints + entrypoint [@coq_type_annotation]) >>? fun (r, ctxt) -> r >>? fun (Ex_ty_cstr {ty = param_type; _}) -> contract_t loc param_type >>? fun res_ty -> @@ -5122,7 +5193,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : I_OPEN_CHEST; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract : +and[@coq_mutual_as_notation] parse_contract_aux : type arg argc. stack_depth:int -> context -> @@ -5162,19 +5233,21 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra code >>? fun (code, ctxt) -> (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code + parse_toplevel_aux ctxt ~legacy:true code >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true arg_type - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) -> (* we don't check targ size here because it's a legacy contract code *) Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) ~error_details:Informative ~full:targ ~expected:arg @@ -5199,8 +5272,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra @@ Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg) else fail (No_such_entrypoint entrypoint) -and parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = - function +and[@coq_struct "ctxt"] parse_view_name ctxt : + Script.node -> (Script_string.t * context) tzresult = function | String (loc, v) as expr -> (* The limitation of length of string is same as entrypoint *) if Compare.Int.(String.length v > 31) then error (View_name_too_long v) @@ -5221,7 +5294,7 @@ and parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) -and parse_toplevel : +and[@coq_struct "toplevel_value"] parse_toplevel_aux : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = fun ctxt ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ -5313,7 +5386,7 @@ and parse_toplevel : Script_ir_annot.error_unexpected_annot sloc sannot >|? fun () -> ({code_field = c; arg_type; views; storage_type = s}, ctxt)) -(* Same as [parse_contract], but does not fail when the contact is missing or +(* Same as [parse_contract_aux], but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. This can still fail on gas exhaustion. *) @@ -5363,11 +5436,11 @@ let parse_contract_for_script : code >>? fun (code, ctxt) -> (* can only fail because of gas *) - match parse_toplevel ctxt ~legacy:true code with + match parse_toplevel_aux ctxt ~legacy:true code with | Error _ -> error (Invalid_contract (loc, contract)) | Ok ({arg_type; _}, ctxt) -> ( - match - parse_parameter_ty_and_entrypoints + match[@coq_match_gadt] + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:0 ~legacy:true @@ -5380,7 +5453,9 @@ let parse_contract_for_script : ctxt ) -> ( (* we don't check targ size here because it's a legacy contract code *) Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a"]) ~error_details:Fast ~full:targ ~expected:arg @@ -5442,12 +5517,16 @@ let parse_code : code >>?= fun (code, ctxt) -> Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code + parse_toplevel_aux ctxt ~legacy code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5495,7 +5574,7 @@ let parse_storage : (fun () -> let storage_type = serialize_ty_for_error storage_type in Ill_typed_data (None, storage, storage_type)) - (parse_data + (parse_data_aux ?type_logger ~stack_depth:0 ctxt @@ -5504,7 +5583,7 @@ let parse_storage : storage_type (root storage)) -let[@coq_axiom_with_reason "gadt"] parse_script : +let parse_script : ?type_logger:type_logger -> context -> legacy:bool -> @@ -5513,10 +5592,17 @@ let[@coq_axiom_with_reason "gadt"] parse_script : (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} -> parse_code ~legacy ctxt ?type_logger ~code - >>=? fun ( Ex_code - (Code - {code; arg_type; storage_type; views; entrypoints; code_size}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_code + (Code + { + code; + arg_type; + storage_type; + views; + entrypoints; + code_size; + }), + ctxt ) -> parse_storage ?type_logger ctxt @@ -5527,7 +5613,15 @@ let[@coq_axiom_with_reason "gadt"] parse_script : >|=? fun (storage, ctxt) -> ( Ex_script (Script - {code_size; code; arg_type; storage; storage_type; views; entrypoints}), + { + code_size; + code; + arg_type; + storage = storage [@coq_type_annotation]; + storage_type; + views; + entrypoints; + }), ctxt ) type typechecked_code_internal = @@ -5541,22 +5635,26 @@ type typechecked_code_internal = } -> typechecked_code_internal -let typecheck_code : +let typecheck_code_inner : legacy:bool -> show_types:bool -> context -> Script.expr -> (typechecked_code_internal * context) tzresult Lwt.t = fun ~legacy ~show_types ctxt code -> - (* Constants need to be expanded or [parse_toplevel] may fail. *) + (* Constants need to be expanded or [parse_toplevel_aux] may fail. *) Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) -> + parse_toplevel_aux ctxt ~legacy code >>?= fun (toplevel, ctxt) -> let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5645,8 +5743,8 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) | Some {name; original_type_expr} -> (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true) in + fold_tree full entrypoints.root [] reachable ([], init) - [@@coq_axiom_with_reason "unsupported syntax"] (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) @@ -5658,7 +5756,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_data : +let[@coq_struct "ctxt"] rec unparse_data_aux : type a ac. context -> stack_depth:int -> @@ -5671,46 +5769,54 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let non_terminal_recursion ctxt mode ty a = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in - match (ty, a) with - | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, address) -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v + | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v + | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v + | (String_t, (s : Script_string.t)) -> + Lwt.return @@ unparse_string ~loc ctxt s + | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b + | (Timestamp_t, (t : Script_timestamp.t)) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | (Address_t, (address : address)) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Contract_t _, contract) -> + | (Contract_t _, (contract : _ typed_contract)) -> Lwt.return @@ unparse_contract ~loc ctxt mode contract - | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Operation_t, operation) -> + | (Signature_t, (s : signature)) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | (Key_hash_t, (k : public_key_hash)) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | (Operation_t, (operation : operation)) -> Lwt.return @@ unparse_operation ~loc ctxt operation - | (Chain_id_t, chain_id) -> + | (Chain_id_t, (chain_id : Script_chain_id.t)) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Bls12_381_g1_t, x) -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | (Bls12_381_g2_t, x) -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | (Bls12_381_fr_t, x) -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | (Pair_t (tl, tr, _, _), pair) -> + | (Bls12_381_g1_t, (x : Script_bls.G1.t)) -> + Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | (Bls12_381_g2_t, (x : Script_bls.G2.t)) -> + Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | (Bls12_381_fr_t, (x : Script_bls.Fr.t)) -> + Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x + | (Pair_t (tl, tr, _, _), (pair : _ * _)) -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | (Union_t (tl, tr, _, _), v) -> + | (Union_t (tl, tr, _, _), (v : _ union)) -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, _), v) -> + | (Option_t (t, _, _), (v : _ option)) -> let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in unparse_option ~loc unparse_v ctxt v - | (List_t (t, _), items) -> + | (List_t (t, _), (items : _ boxed_list)) -> List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -5718,19 +5824,20 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) items.elements >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | (Ticket_t (t, _), {ticketer; contents; amount}) -> + | (Ticket_t (t, _), (x : _ ticket)) -> + let {ticketer; contents; amount} = x in (* ideally we would like to allow a little overhead here because it is only used for unparsing *) opened_ticket_type loc t >>?= fun opened_ticket_ty -> let t = ty_of_comparable_ty opened_ticket_ty in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data [@tailcall]) + (unparse_data_aux [@tailcall]) ctxt ~stack_depth mode t (addr, (contents, amount)) - | (Set_t (t, _), set) -> + | (Set_t (t, _), (set : _ set)) -> List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> @@ -5738,65 +5845,82 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Map_t (kt, vt, _), map) -> + | (Map_t (kt, vt, _), (map : _ map)) -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _}) - when Compare.Int.( = ) size 0 -> - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - | (Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _}) -> - let items = - Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | (Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _}) -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Lambda_t _, Lam (_, original_code)) -> - unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + | (Big_map_t (kt, vt, _), (x : _ big_map)) -> ( + match[@coq_match_gadt] x with + | Big_map {id; diff = {map; size; _}; _} -> ( + match id with + | Some id -> + if Compare.Int.( = ) size 0 then + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + else + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> (k, v) :: acc) + map + [] + in + let items = + (* Sort the items in Michelson comparison order and not in key + hash order. This code path is only exercised for tracing, + so we don't bother carbonating this sort operation + precisely. Also, the sort uses a reverse compare because + [unparse_items] will reverse the result. *) + List.sort + (fun (a, _) (b, _) -> + Script_comparable.compare_comparable kt b a) + items + in + (* this can't fail if the original type is well-formed + because [option vt] is always strictly smaller than [big_map kt vt] *) + option_t loc vt >>?= fun vt -> + unparse_items + ctxt + ~stack_depth:(stack_depth + 1) + mode + kt + vt + items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ), + ctxt ) + | None -> + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + map + [] + in + let items = + (* See note above. *) + List.sort + (fun (a, _) (b, _) -> + Script_comparable.compare_comparable kt b a) + items + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt))) + | (Lambda_t _, (x : _ lambda)) -> + let (Lam (_, original_code)) = x in + unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code | (Never_t, _) -> . - | (Sapling_transaction_t _, s) -> + | (Sapling_transaction_t _, (s : Sapling.transaction)) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in (Bytes (loc, bytes), ctxt) ) - | (Sapling_transaction_deprecated_t _, s) -> + | (Sapling_transaction_deprecated_t _, (s : Sapling_repr.legacy_transaction)) + -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) >|? fun ctxt -> @@ -5806,7 +5930,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : s in (Bytes (loc, bytes), ctxt) ) - | (Sapling_state_t _, {id; diff; _}) -> + | (Sapling_state_t _, (x : Sapling.state)) -> + let {Sapling.id; diff; _} = x in Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with @@ -5828,14 +5953,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : Micheline.Prim (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) - | (Chest_key_t, s) -> + | (Chest_key_t, (s : Script_timelock.chest_key)) -> unparse_with_data_encoding ~loc ctxt s Unparse_costs.chest_key Script_timelock.chest_key_encoding - | (Chest_t, s) -> + | (Chest_t, (s : Script_timelock.chest)) -> unparse_with_data_encoding ~loc ctxt @@ -5844,7 +5969,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ~plaintext_size:(Script_timelock.get_plaintext_size s)) Script_timelock.chest_encoding -and unparse_items : +and[@coq_mutual_as_notation] unparse_items : type k v vc. context -> stack_depth:int -> @@ -5858,23 +5983,25 @@ and unparse_items : (fun (l, ctxt) (k, v) -> let loc = Micheline.dummy_location in unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) items -and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = +and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) + (mode : unparsing_mode) (code : Script.node) : + (node * context, error trace) result Lwt.t = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + else unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun (Ex_ty t, ctxt) -> + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -5882,7 +6009,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - parse_data + parse_data_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -5890,7 +6017,12 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = t data >>=? fun (data, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_aux + ctxt + ~stack_depth:(stack_depth + 1) + mode + t + (data [@coq_type_annotation]) >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -5913,14 +6045,21 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = return (Prim (loc, prim, List.rev items, annot), ctxt) | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) -let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage - mode ~normalize_types {code; storage} = +let parse_and_unparse_script_unaccounted : + context -> + legacy:bool -> + allow_forged_in_storage:bool -> + unparsing_mode -> + normalize_types:bool -> + Script.t -> + (Script.t * context) tzresult Lwt.t = + fun ctxt ~legacy ~allow_forged_in_storage mode ~normalize_types {code; storage} -> Script.force_decode_in_context ~consume_deserialization_gas:When_needed ctxt code >>?= fun (code, ctxt) -> - typecheck_code ~legacy ~show_types:false ctxt code + typecheck_code_inner ~legacy ~show_types:false ctxt code >>=? fun ( Typechecked_code_internal { toplevel = @@ -5937,15 +6076,15 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage type_map = _; }, ctxt ) -> - parse_storage + (parse_storage [@coq_implicit "storage" "a"]) ctxt ~legacy ~allow_forged:allow_forged_in_storage storage_type ~storage >>=? fun (storage, ctxt) -> - unparse_code ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> - unparse_data ctxt ~stack_depth:0 mode storage_type storage + unparse_code_aux ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> + unparse_data_aux ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> let loc = Micheline.dummy_location in (if normalize_types then @@ -5967,7 +6106,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage >>=? fun (arg_type, storage_type, views, ctxt) -> Script_map.map_es_in_context (fun ctxt _name {input_ty; output_ty; view_code} -> - unparse_code ctxt ~stack_depth:0 mode view_code + unparse_code_aux ctxt ~stack_depth:0 mode view_code >|=? fun (view_code, ctxt) -> ({input_ty; output_ty; view_code}, ctxt)) ctxt views @@ -6005,7 +6144,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt ) let pack_data_with_mode ctxt ty data ~mode = - unparse_data ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> + unparse_data_aux ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt let hash_data ctxt ty data = @@ -6017,11 +6156,11 @@ let pack_data ctxt ty data = (* ---------------- Big map -------------------------------------------------*) -let empty_big_map key_type value_type = +let empty_big_map key_type value_type : ('a, 'b) big_map = Big_map { id = None; - diff = {map = Big_map_overlay.empty; size = 0}; + diff = {map = Big_map_overlay.empty; size = 0} [@coq_type_annotation]; key_type; value_type; } @@ -6035,40 +6174,44 @@ let big_map_mem ctxt key (Big_map {id; diff; key_type; _}) = | (Some (_, None), _) -> return (false, ctxt) | (Some (_, Some _), _) -> return (true, ctxt) -let big_map_get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = - match (Big_map_overlay.find key diff.map, id) with - | (Some (_, x), _) -> return (x, ctxt) - | (None, None) -> return (None, ctxt) - | (None, Some id) -> ( - Alpha_context.Big_map.get_opt ctxt id key >>=? function - | (ctxt, None) -> return (None, ctxt) - | (ctxt, Some value) -> - parse_data - ~stack_depth:0 - ctxt - ~legacy:true - ~allow_forged:true - value_type - (Micheline.root value) - >|=? fun (x, ctxt) -> (Some x, ctxt)) +let big_map_get_by_hash ctxt key big_map = + match[@coq_match_gadt] big_map with + | Big_map {id; diff; value_type; _} -> ( + match (Big_map_overlay.find key diff.map, id) with + | (Some (_, x), _) -> return (x, ctxt) + | (None, None) -> return (None, ctxt) + | (None, Some id) -> ( + Alpha_context.Big_map.get_opt ctxt id key >>=? function + | (ctxt, None) -> return (None, ctxt) + | (ctxt, Some value) -> + parse_data_aux + ~stack_depth:0 + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >|=? fun (x, ctxt) -> (Some x, ctxt))) let big_map_get ctxt key (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - big_map_get_by_hash ctxt key_hash map + (big_map_get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map -let big_map_update_by_hash ctxt key_hash key value (Big_map map) = - let contains = Big_map_overlay.mem key_hash map.diff.map in - return - ( Big_map - { - map with - diff = +let big_map_update_by_hash ctxt key_hash key value map = + match[@coq_match_gadt] map with + | Big_map map -> + let contains = Big_map_overlay.mem key_hash map.diff.map in + return + ( Big_map { - map = Big_map_overlay.add key_hash (key, value) map.diff.map; - size = (if contains then map.diff.size else map.diff.size + 1); - }; - }, - ctxt ) + map with + diff = + { + map = Big_map_overlay.add key_hash (key, value) map.diff.map; + size = (if contains then map.diff.size else map.diff.size + 1); + }; + }, + ctxt ) let big_map_update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> @@ -6077,8 +6220,8 @@ let big_map_update ctxt key value (Big_map {key_type; _} as map) = let big_map_get_and_update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> big_map_update_by_hash ctxt key_hash key value map >>=? fun (map', ctxt) -> - big_map_get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) -> - return ((old_value, map'), ctxt) + (big_map_get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map + >>=? fun (old_value, ctxt) -> return ((old_value, map'), ctxt) (* ---------------- Lazy storage---------------------------------------------*) @@ -6087,60 +6230,63 @@ type lazy_storage_ids = Lazy_storage.IdSet.t let no_lazy_storage_id = Lazy_storage.IdSet.empty let diff_of_big_map ctxt mode ~temporary ~ids_to_copy - (Big_map {id; key_type; value_type; diff}) = - (match id with - | Some id -> - if Lazy_storage.IdSet.mem Big_map id ids_to_copy then - Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> - (ctxt, Lazy_storage.Copy {src = id}, duplicate) - else - (* The first occurrence encountered of a big_map reuses the - ID. This way, the payer is only charged for the diff. - For this to work, this diff has to be put at the end of - the global diff, otherwise the duplicates will use the - updated version as a base. This is true because we add - this diff first in the accumulator of - `extract_lazy_storage_updates`, and this accumulator is not - reversed. *) - return (ctxt, Lazy_storage.Existing, id) - | None -> - Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> - Lwt.return - (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in - Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> - unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> - let key_type = Micheline.strip_locations kt in - let value_type = Micheline.strip_locations kv in - (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) - >>=? fun (ctxt, init, id) -> - let pairs = - Big_map_overlay.fold - (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) - diff.map - [] - in - List.fold_left_es - (fun (acc, ctxt) (key_hash, key, value) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - unparse_comparable_data ~loc:() ctxt mode key_type key - >>=? fun (key_node, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt -> - let key = Micheline.strip_locations key_node in - (match value with - | None -> return (None, ctxt) - | Some x -> - unparse_data ~stack_depth:0 ctxt mode value_type x - >>=? fun (node, ctxt) -> + (big_map : ('a, 'b) big_map) = + match[@coq_match_gadt] big_map with + | Big_map {id; key_type; value_type; diff} -> + (match id with + | Some id -> + if Lazy_storage.IdSet.mem Big_map id ids_to_copy then + Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else + (* The first occurrence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_lazy_storage_updates`, and this accumulator is not + reversed. *) + return (ctxt, Lazy_storage.Existing, id) + | None -> + Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> Lwt.return - ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> - (Some (Micheline.strip_locations node), ctxt) )) - >|=? fun (value, ctxt) -> - let diff_item = Big_map.{key; key_hash; value} in - (diff_item :: acc, ctxt)) - ([], ctxt) - (List.rev pairs) - >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) + (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in + Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> + unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> + let key_type = Micheline.strip_locations kt in + let value_type = Micheline.strip_locations kv in + (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) + >>=? fun (ctxt, init, id) -> + let pairs : (Script_expr_hash.t * 'a * 'b option) list = + Big_map_overlay.fold + (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) + diff.map + [] + in + List.fold_left_es + (fun (acc, ctxt) (key_hash, key, value) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> + unparse_comparable_data ~loc:() ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost key_node) + >>?= fun ctxt -> + let key = Micheline.strip_locations key_node in + (match value with + | None -> return (None, ctxt) + | Some x -> + unparse_data_aux ~stack_depth:0 ctxt mode value_type x + >>=? fun (node, ctxt) -> + Lwt.return + ( Gas.consume ctxt (Script.strip_locations_cost node) + >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) )) + >|=? fun (value, ctxt) -> + let diff_item = Big_map.{key; key_hash; value} in + (diff_item :: acc, ctxt)) + ([], ctxt) + (List.rev pairs) + >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) let diff_of_sapling_state ctxt ~temporary ~ids_to_copy ({id; diff; memo_size} : Sapling.state) = @@ -6239,6 +6385,168 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = | List_t (t, _) -> aux1 (fun h -> List_f h) t | Map_t (_, t, _) -> aux1 (fun h -> Map_f h) t +let[@coq_struct "has_lazy_storage_value"] rec extract_lazy_storage_updates_aux : + type a ac. + context -> + unparsing_mode -> + temporary:bool -> + Lazy_storage.IdSet.t -> + Lazy_storage.diffs -> + (a, ac) ty -> + a -> + has_lazy_storage:a has_lazy_storage -> + (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = + fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with + | (False_f, _, _) -> return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] + | (Big_map_f, Big_map_t (_, _, _), (map : _ big_map)) -> + diff_of_big_map ctxt mode ~temporary ~ids_to_copy map + >|=? fun (diff, id, ctxt) -> + let map = + let (Big_map map) = map in + Big_map + { + map with + diff = {map = Big_map_overlay.empty; size = 0}; + id = Some id; + } + in + let diff = Lazy_storage.make Big_map id diff in + let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in + (ctxt, map, ids_to_copy, diff :: acc) + | (Sapling_state_f, Sapling_state_t _, (sapling_state : Sapling.state)) -> + diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state + >|=? fun (diff, id, ctxt) -> + let sapling_state = + Sapling.empty_state ~id ~memo_size:sapling_state.memo_size () + in + let diff = Lazy_storage.make Sapling_state id diff in + let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in + (ctxt, sapling_state, ids_to_copy, diff :: acc) + | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) -> + let (xl, xr) = x in + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyl + xl + ~has_lazy_storage:hl + >>=? fun (ctxt, xl, ids_to_copy, acc) -> + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyr + xr + ~has_lazy_storage:hr + >|=? fun (ctxt, xr, ids_to_copy, acc) -> (ctxt, (xl, xr), ids_to_copy, acc) + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyl + x + ~has_lazy_storage:has_lazy_storage_l + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) + | R x -> + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyr + x + ~has_lazy_storage:has_lazy_storage_r + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc)) + | (Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option)) -> ( + match x with + | Some x -> + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + ty + x + ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, Some x, ids_to_copy, acc) + | None -> return (ctxt, None, ids_to_copy, acc)) + | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) -> + List.fold_left_es + (fun (ctxt, l, ids_to_copy, acc) x -> + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + ty + x + ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, Script_list.cons x l, ids_to_copy, acc)) + (ctxt, Script_list.empty, ids_to_copy, acc) + l.elements + >|=? fun (ctxt, l, ids_to_copy, acc) -> + let reversed = {length = l.length; elements = List.rev l.elements} in + (ctxt, reversed, ids_to_copy, acc) + | (Map_f has_lazy_storage, Map_t (_, ty, _), (map : _ map)) -> + let (module M) = Script_map.get_module map in + let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in + List.fold_left_es + (fun (ctxt, m, ids_to_copy, acc) (k, x) -> + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + ty + x + ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, M.OPS.add k x m, ids_to_copy, acc)) + (ctxt, M.OPS.empty, ids_to_copy, acc) + (bindings M.boxed) + >|=? fun (ctxt, m, ids_to_copy, acc) -> + let module M : Boxed_map with type key = M.key and type value = M.value = + struct + module OPS = M.OPS + + type key = M.key + + type value = M.value + + let boxed = m + + let size = M.size + + let boxed_map_tag = () + end in + ( ctxt, + Script_map.make + (module M : Boxed_map with type key = M.key and type value = M.value), + ids_to_copy, + acc ) + (** Transforms a value potentially containing lazy storage in an intermediary state to a value containing lazy storage only represented by identifiers. @@ -6247,106 +6555,17 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = storage diff to show on the receipt and apply on the storage. *) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode - ~temporary ids_to_copy acc ty x = - let rec aux : - type a ac. - context -> - unparsing_mode -> - temporary:bool -> - Lazy_storage.IdSet.t -> - Lazy_storage.diffs -> - (a, ac) ty -> - a -> - has_lazy_storage:a has_lazy_storage -> - (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = - fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match (has_lazy_storage, ty, x) with - | (False_f, _, _) -> return (ctxt, x, ids_to_copy, acc) - | (Big_map_f, Big_map_t (_, _, _), map) -> - diff_of_big_map ctxt mode ~temporary ~ids_to_copy map - >|=? fun (diff, id, ctxt) -> - let map = - let (Big_map map) = map in - Big_map - { - map with - diff = {map = Big_map_overlay.empty; size = 0}; - id = Some id; - } - in - let diff = Lazy_storage.make Big_map id diff in - let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in - (ctxt, map, ids_to_copy, diff :: acc) - | (Sapling_state_f, Sapling_state_t _, sapling_state) -> - diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state - >|=? fun (diff, id, ctxt) -> - let sapling_state = - Sapling.empty_state ~id ~memo_size:sapling_state.memo_size () - in - let diff = Lazy_storage.make Sapling_state id diff in - let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in - (ctxt, sapling_state, ids_to_copy, diff :: acc) - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) -> - aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl - >>=? fun (ctxt, xl, ids_to_copy, acc) -> - aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr - >|=? fun (ctxt, xr, ids_to_copy, acc) -> - (ctxt, (xl, xr), ids_to_copy, acc) - | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) - | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) - | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) - | (List_f has_lazy_storage, List_t (ty, _), l) -> - List.fold_left_es - (fun (ctxt, l, ids_to_copy, acc) x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> - (ctxt, Script_list.cons x l, ids_to_copy, acc)) - (ctxt, Script_list.empty, ids_to_copy, acc) - l.elements - >|=? fun (ctxt, l, ids_to_copy, acc) -> - let reversed = {length = l.length; elements = List.rev l.elements} in - (ctxt, reversed, ids_to_copy, acc) - | (Map_f has_lazy_storage, Map_t (_, ty, _), map) -> - let (module M) = Script_map.get_module map in - let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in - List.fold_left_es - (fun (ctxt, m, ids_to_copy, acc) (k, x) -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> - (ctxt, M.OPS.add k x m, ids_to_copy, acc)) - (ctxt, M.OPS.empty, ids_to_copy, acc) - (bindings M.boxed) - >|=? fun (ctxt, m, ids_to_copy, acc) -> - let module M = struct - module OPS = M.OPS - - type key = M.key - - type value = M.value - - let boxed = m - - let size = M.size - end in - ( ctxt, - Script_map.make - (module M : Boxed_map - with type key = M.key - and type value = M.value), - ids_to_copy, - acc ) - | (_, Option_t (_, _, _), None) -> return (ctxt, None, ids_to_copy, acc) - in +let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let has_lazy_storage = has_lazy_storage ty in - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + extract_lazy_storage_updates_aux + ctxt + mode + ~temporary + ids_to_copy + acc + ty + x + ~has_lazy_storage (** We namespace an error type for [fold_lazy_storage]. The error case is only available when the ['error] parameter is equal to unit. *) @@ -6359,7 +6578,7 @@ end (** Prematurely abort if [f] generates an error. Use this function without the [unit] type for [error] if you are in a case where errors are impossible. *) -let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : +let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : type a ac error. f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f -> init:'acc -> @@ -6370,33 +6589,55 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - match (has_lazy_storage, ty, x) with - | (Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _}) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) - | (Sapling_state_f, Sapling_state_t _, {id = Some id; _}) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + match[@coq_match_gadt] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with + | (Big_map_f, Big_map_t (_, _, _), (x : _ big_map)) -> ( + match x with + | Big_map {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) + | Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) + | (Sapling_state_f, Sapling_state_t _, (x : Alpha_context.Sapling.state)) -> ( + match x with + | {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + | {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) | (False_f, _, _) -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _}) -> - ok (Fold_lazy_storage.Ok init, ctxt) - | (Sapling_state_f, Sapling_state_t _, {id = None; _}) -> - ok (Fold_lazy_storage.Ok init, ctxt) - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) -> ( + | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) -> ( + let (xl, xr) = x in fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl >>? fun (init, ctxt) -> match init with | Fold_lazy_storage.Ok init -> fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr | Fold_lazy_storage.Error -> ok (init, ctxt)) - | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (_, Option_t (_, _, _), None) -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (List_f has_lazy_storage, List_t (ty, _), l) -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + fold_lazy_storage + ~f + ~init + ctxt + tyl + x + ~has_lazy_storage:has_lazy_storage_l + | R x -> + fold_lazy_storage + ~f + ~init + ctxt + tyr + x + ~has_lazy_storage:has_lazy_storage_r) + | (Option_f has_lazy_storage, Option_t (ty, _, _), (o : _ option)) -> ( + match o with + | None -> ok (Fold_lazy_storage.Ok init, ctxt) + | Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage) + | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) -> List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -6405,7 +6646,7 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : | Fold_lazy_storage.Error -> ok (init, ctxt)) (Fold_lazy_storage.Ok init, ctxt) l.elements - | (Map_f has_lazy_storage, Map_t (_, ty, _), m) -> + | (Map_f has_lazy_storage, Map_t (_, ty, _), (m : _ map)) -> Script_map.fold (fun _ v @@ -6418,18 +6659,21 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : m (ok (Fold_lazy_storage.Ok init, ctxt)) -let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x = +let collect_lazy_storage ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f kind id (acc : (_, never) Fold_lazy_storage.result) = - let acc = match acc with Fold_lazy_storage.Ok acc -> acc in + let acc = + match[@coq_match_with_default] acc with Fold_lazy_storage.Ok acc -> acc + in Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc) in fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage >>? fun (ids, ctxt) -> - match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt) + match[@coq_match_with_default] ids with + | Fold_lazy_storage.Ok ids -> ok (ids, ctxt) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode - ~temporary ~to_duplicate ~to_update ty v = +let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v + = (* Basically [to_duplicate] are ids from the argument and [to_update] are ids from the storage before execution (i.e. it is safe to reuse them since they @@ -6442,10 +6686,15 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode if temporary then diffs else let dead = Lazy_storage.IdSet.diff to_update alive in - Lazy_storage.IdSet.fold_all - {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)} - dead - diffs + let f kind id acc = + (Lazy_storage.make + [@coq_implicit "a" "unit"] [@coq_implicit "u" "unit"]) + kind + id + Remove + :: acc + in + Lazy_storage.IdSet.fold_all {f} dead diffs in match diffs with | [] -> (v, None, ctxt) @@ -6454,7 +6703,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] -let parse_data = parse_data ~stack_depth:0 +let parse_data = parse_data_aux ~stack_depth:0 let parse_instr : type a s. @@ -6466,7 +6715,7 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> - parse_instr + parse_instr_aux ~stack_depth:0 ?type_logger tc_context @@ -6475,41 +6724,41 @@ let parse_instr : script_instr stack_ty -let unparse_data = unparse_data ~stack_depth:0 +let unparse_data = unparse_data_aux ~stack_depth:0 let unparse_code ctxt mode code = - (* Constants need to be expanded or [unparse_code] may fail. *) + (* Constants need to be expanded or [unparse_code_aux] may fail. *) Global_constants_storage.expand ctxt (strip_locations code) - >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code) + >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code) let parse_contract context loc arg_ty contract ~entrypoint = - parse_contract ~stack_depth:0 context loc arg_ty contract ~entrypoint + parse_contract_aux ~stack_depth:0 context loc arg_ty contract ~entrypoint let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> - Lwt.return @@ parse_toplevel ctxt ~legacy toplevel + Lwt.return @@ parse_toplevel_aux ctxt ~legacy toplevel -let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 +let parse_comparable_ty = parse_comparable_ty_aux ~stack_depth:0 -let parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0 +let parse_big_map_value_ty = parse_big_map_value_ty_aux ~stack_depth:0 -let parse_packable_ty = parse_packable_ty ~stack_depth:0 +let parse_packable_ty = parse_packable_ty_aux ~stack_depth:0 -let parse_passable_ty = parse_passable_ty ~stack_depth:0 +let parse_passable_ty = parse_passable_ty_aux ~stack_depth:0 -let parse_any_ty = parse_any_ty ~stack_depth:0 +let parse_any_ty = parse_any_ty_aux ~stack_depth:0 -let parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints +let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = - parse_parameter_ty_and_entrypoints ~stack_depth:0 + parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 -let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = +let get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = - match kind with - | Lazy_storage.Kind.Sapling_state -> ( + match[@coq_match_gadt] (kind, id) with + | (Lazy_storage.Kind.Sapling_state, (id : Sapling.Id.t)) -> ( match single_id_opt with | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id) | Fold_lazy_storage.Ok (Some _) -> @@ -6569,5 +6818,5 @@ let script_size (Saturation_repr.(add code_size storage_size |> to_int), cost) let typecheck_code ~legacy ~show_types ctxt code = - typecheck_code ~legacy ~show_types ctxt code + typecheck_code_inner ~legacy ~show_types ctxt code >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt) diff --git a/src/proto_013_PtJakart/lib_protocol/script_ir_translator.mli b/src/proto_013_PtJakart/lib_protocol/script_ir_translator.mli index 9ab18aeeaeece..a27020d6a1e55 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_ir_translator.mli +++ b/src/proto_013_PtJakart/lib_protocol/script_ir_translator.mli @@ -111,6 +111,7 @@ type ('arg, 'storage) code = field as it has a dynamic size. *) } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_code = Ex_code : ('a, 'c) code -> ex_code @@ -127,6 +128,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view + [@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) Script_typed_ir.map diff --git a/src/proto_013_PtJakart/lib_protocol/script_map.ml b/src/proto_013_PtJakart/lib_protocol/script_map.ml index a9c3746dda63a..af04148abaed4 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_map.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_map.ml @@ -45,18 +45,36 @@ let empty_from : type a b c. (a, b) map -> (a, c) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let empty : type a b. a comparable_ty -> (a, b) map = fun ty -> - let module OPS = struct + let module OPS : Boxed_map_OPS with type key = a = struct let key_size = Gas_comparable_input_size.size_of_comparable_value ty - include Map.Make (struct + module Map = Map.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type 'a t = 'a Map.t + + type key = Map.key + + let empty = Map.empty + + let add = Map.add + + let remove = Map.remove + + let find = Map.find + + let fold = Map.fold + + let fold_es = Map.fold_es end in Map_tag (module struct @@ -69,6 +87,8 @@ let empty : type a b. a comparable_ty -> (a, b) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let get : type key value. key -> (key, value) map -> value option = @@ -95,6 +115,8 @@ let update : type a b. a -> b option -> (a, b) map -> (a, b) map = let boxed = boxed let size = size + + let boxed_map_tag = () end) let mem : type key value. key -> (key, value) map -> bool = @@ -142,5 +164,7 @@ let map_es_in_context : let boxed = map let size = Box.size + + let boxed_map_tag = () end), ctxt ) diff --git a/src/proto_013_PtJakart/lib_protocol/script_repr.ml b/src/proto_013_PtJakart/lib_protocol/script_repr.ml index 681d6d7c627a5..139f9cc215b03 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_repr.ml @@ -254,11 +254,13 @@ let force_decode_cost lexpr = ~fun_combine:(fun _ _ -> Gas_limit_repr.free) lexpr +type 'a bytes_or_value = Only_value of 'a | Has_bytes of bytes + let stable_force_decode_cost lexpr = let has_bytes = Data_encoding.apply_lazy - ~fun_value:(fun v -> `Only_value v) - ~fun_bytes:(fun b -> `Has_bytes b) + ~fun_value:(fun v -> Only_value v) + ~fun_bytes:(fun b -> Has_bytes b) ~fun_combine:(fun _v b -> (* When the lazy_expr contains both a deserialized version and a serialized one, we compute the cost from the @@ -267,8 +269,8 @@ let stable_force_decode_cost lexpr = lexpr in match has_bytes with - | `Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) - | `Only_value v -> + | Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) + | Only_value v -> (* This code path should not be reached in theory because values that are decoded should have been encoded before. Here we use Data_encoding.Binary.length, which yields the same results @@ -312,7 +314,7 @@ let is_unit_parameter = ~fun_bytes:(fun b -> Compare.Bytes.equal b unit_bytes) ~fun_combine:(fun res _ -> res) -let[@coq_struct "node"] rec strip_annotations node = +let[@coq_struct "node_value"] rec strip_annotations node = let open Micheline in match node with | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> leaf @@ -320,7 +322,7 @@ let[@coq_struct "node"] rec strip_annotations node = Prim (loc, name, List.map strip_annotations args, []) | Seq (loc, args) -> Seq (loc, List.map strip_annotations args) -let rec micheline_fold_aux node f acc k = +let rec micheline_fold_aux (node : _ michelson_node) f acc k = match node with | Micheline.Int (_, _) -> k (f acc node) | Micheline.String (_, _) -> k (f acc node) diff --git a/src/proto_013_PtJakart/lib_protocol/script_set.ml b/src/proto_013_PtJakart/lib_protocol/script_set.ml index 22a37d1cc10d7..15a650c3d62e7 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_set.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_set.ml @@ -37,11 +37,25 @@ let empty : type a. a comparable_ty -> a set = let module OPS : Boxed_set_OPS with type elt = a = struct let elt_size = Gas_comparable_input_size.size_of_comparable_value ty - include Set.Make (struct + module Set = Set.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type t = Set.t + + type elt = Set.elt + + let empty = Set.empty + + let add = Set.add + + let mem = Set.mem + + let remove = Set.remove + + let fold = Set.fold end in Set_tag (module struct diff --git a/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml b/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml index b3108eb31ef23..ea0c6bca872cc 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_string_repr.ml @@ -57,7 +57,7 @@ let () = let empty = String_tag "" let of_string v = - let rec check_printable_ascii i = + let[@coq_struct "i_value"] rec check_printable_ascii i = if Compare.Int.(i < 0) then ok (String_tag v) else match v.[i] with diff --git a/src/proto_013_PtJakart/lib_protocol/script_typed_ir.ml b/src/proto_013_PtJakart/lib_protocol/script_typed_ir.ml index cb9b0ab5f7c13..b6dfac27c1cfa 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_typed_ir.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_typed_ir.ml @@ -241,7 +241,7 @@ module type TYPE_SIZE = sig submodule), the type is abstract but we have access to unsafe constructors that can break the invariant. *) - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:'error_trace Script_tc_errors.error_details -> @@ -296,7 +296,7 @@ module Type_size : TYPE_SIZE = struct if Compare.Int.(x = y) then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative -> trace_of_error @@ Script_tc_errors.Inconsistent_type_sizes (x, y)) @@ -399,6 +399,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end type ('key, 'value) map = @@ -465,6 +467,7 @@ type ('arg, 'storage) script = field as it has a dynamic size. *) } -> ('arg, 'storage) script +[@@coq_force_gadt] (* ---- Instructions --------------------------------------------------------*) and ('before_top, 'before, 'result_top, 'result) kinstr = @@ -1149,6 +1152,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] and (_, _, _, _) continuation = | KNil : ('r, 'f, 'r, 'f) continuation @@ -1300,6 +1304,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1365,6 +1370,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction : { @@ -1800,7 +1806,8 @@ let ty_metadata : type a ac. (a, ac) ty -> a ty_metadata = function | Bls12_381_fr_t | Chest_t | Chest_key_t -> meta_basic -let comparable_ty_metadata : type a. a comparable_ty -> a ty_metadata = function +let comparable_ty_metadata : type a. a comparable_ty -> a ty_metadata = + function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t -> @@ -1849,7 +1856,8 @@ let is_comparable : type v c. (v, c) ty -> c dbool = function | Chest_t -> No | Chest_key_t -> No -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] let unit_t = Unit_t @@ -2233,7 +2241,7 @@ type 'a ty_traverse = { apply_comparable : 't. 'a -> 't comparable_ty -> 'a; } -let (ty_traverse, comparable_ty_traverse) = +module Ty_traverse = struct let rec aux : type t ret accu. accu ty_traverse -> accu -> t comparable_ty -> (accu -> ret) -> ret = @@ -2249,7 +2257,7 @@ let (ty_traverse, comparable_ty_traverse) = (continue [@ocaml.tailcall]) accu in let return () = (continue [@ocaml.tailcall]) accu in - match ty with + match[@coq_match_with_default] ty with | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t | Bool_t | Chain_id_t | Never_t -> @@ -2257,7 +2265,8 @@ let (ty_traverse, comparable_ty_traverse) = | Pair_t (ty1, ty2, _, YesYes) -> (next2 [@ocaml.tailcall]) ty1 ty2 | Union_t (ty1, ty2, _, YesYes) -> (next2 [@ocaml.tailcall]) ty1 ty2 | Option_t (ty, _, Yes) -> (next [@ocaml.tailcall]) ty - and aux' : + + let rec aux' : type ret t tc accu. accu ty_traverse -> accu -> (t, tc) ty -> (accu -> ret) -> ret = fun f accu ty continue -> @@ -2287,7 +2296,8 @@ let (ty_traverse, comparable_ty_traverse) = (aux [@ocaml.tailcall]) f accu cty @@ fun accu -> (next' [@ocaml.tailcall]) f accu ty1 continue | Contract_t (ty1, _) -> (next' [@ocaml.tailcall]) f accu ty1 continue - and next2' : + + and[@coq_mutual_as_notation] next2' : type a ac b bc ret accu. accu ty_traverse -> accu -> @@ -2299,15 +2309,19 @@ let (ty_traverse, comparable_ty_traverse) = (aux' [@ocaml.tailcall]) f accu ty1 @@ fun accu -> (aux' [@ocaml.tailcall]) f accu ty2 @@ fun accu -> (continue [@ocaml.tailcall]) accu - and next' : + + and[@coq_mutual_as_notation] next' : type a ac ret accu. accu ty_traverse -> accu -> (a, ac) ty -> (accu -> ret) -> ret = fun f accu ty1 continue -> (aux' [@ocaml.tailcall]) f accu ty1 @@ fun accu -> (continue [@ocaml.tailcall]) accu - in - ( (fun ty init f -> aux' f init ty (fun accu -> accu)), - fun cty init f -> aux f init cty (fun accu -> accu) ) +end + +let comparable_ty_traverse cty init f = + Ty_traverse.aux f init cty (fun accu -> accu) + +let ty_traverse ty init f = Ty_traverse.aux' f init ty (fun accu -> accu) type 'accu stack_ty_traverse = { apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu; @@ -2327,118 +2341,177 @@ type 'a value_traverse = { apply_comparable : 't. 'a -> 't comparable_ty -> 't -> 'a; } -let value_traverse (type t tc) (ty : ((t, tc) ty, t comparable_ty) union) - (x : t) init f = - let rec aux : type ret t tc. 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret - = - fun accu ty x continue -> - let accu = f.apply accu ty x in - let next2 ty1 ty2 x1 x2 = - (aux [@ocaml.tailcall]) accu ty1 x1 @@ fun accu -> - (aux [@ocaml.tailcall]) accu ty2 x2 @@ fun accu -> - (continue [@ocaml.tailcall]) accu - in - let next ty1 x1 = - (aux [@ocaml.tailcall]) accu ty1 x1 @@ fun accu -> - (continue [@ocaml.tailcall]) accu - in - let return () = (continue [@ocaml.tailcall]) accu in - let rec on_list ty' accu = function - | [] -> (continue [@ocaml.tailcall]) accu - | x :: xs -> - (aux [@ocaml.tailcall]) accu ty' x @@ fun accu -> - (on_list [@ocaml.tailcall]) ty' accu xs - in - match ty with - | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t - | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t - | Bool_t | Sapling_transaction_t _ | Sapling_transaction_deprecated_t _ - | Sapling_state_t _ | Operation_t | Chain_id_t | Never_t | Bls12_381_g1_t - | Bls12_381_g2_t | Bls12_381_fr_t | Chest_key_t | Chest_t - | Lambda_t (_, _, _) -> - (return [@ocaml.tailcall]) () - | Pair_t (ty1, ty2, _, _) -> - (next2 [@ocaml.tailcall]) ty1 ty2 (fst x) (snd x) - | Union_t (ty1, ty2, _, _) -> ( - match x with - | L l -> (next [@ocaml.tailcall]) ty1 l - | R r -> (next [@ocaml.tailcall]) ty2 r) - | Option_t (ty, _, _) -> ( - match x with - | None -> return () - | Some v -> (next [@ocaml.tailcall]) ty v) - | Ticket_t (cty, _) -> (aux' [@ocaml.tailcall]) accu cty x.contents continue - | List_t (ty', _) -> on_list ty' accu x.elements - | Map_t (kty, ty', _) -> - let (Map_tag (module M)) = x in - let bindings = M.OPS.fold (fun k v bs -> (k, v) :: bs) M.boxed [] in - on_bindings accu kty ty' continue bindings - | Set_t (ty', _) -> - let (Set_tag (module M)) = x in - let elements = M.OPS.fold (fun x s -> x :: s) M.boxed [] in - on_list' accu ty' elements continue - | Big_map_t (_, _, _) -> - (* For big maps, there is no obvious recursion scheme so we - delegate this case to the client. *) - (return [@ocaml.tailcall]) () - | Contract_t (_, _) -> (return [@ocaml.tailcall]) () - and on_list' : - type ret t. 'accu -> t comparable_ty -> t list -> ('accu -> ret) -> ret = - fun accu ty' xs continue -> - match xs with +let[@coq_struct "ty_value"] rec value_traverse_aux : + type ret t tc. + 'accu -> (t, tc) ty -> t -> 'a value_traverse -> ('accu -> ret) -> ret = + fun accu ty_value x f continue -> + let accu = f.apply accu ty_value x in + let next2 ty1 ty2 x1 x2 = + (value_traverse_aux [@ocaml.tailcall]) accu ty1 x1 f @@ fun accu -> + (value_traverse_aux [@ocaml.tailcall]) accu ty2 x2 f @@ fun accu -> + (continue [@ocaml.tailcall]) accu + in + let next ty1 x1 = + (value_traverse_aux [@ocaml.tailcall]) accu ty1 x1 f @@ fun accu -> + (continue [@ocaml.tailcall]) accu + in + let return () = (continue [@ocaml.tailcall]) accu in + let[@coq_struct "function_parameter"] rec on_list ty_value accu = function | [] -> (continue [@ocaml.tailcall]) accu | x :: xs -> - (aux' [@ocaml.tailcall]) accu ty' x @@ fun accu -> - (on_list' [@ocaml.tailcall]) accu ty' xs continue - and on_bindings : - type ret k v vc. - 'accu -> - k comparable_ty -> - (v, vc) ty -> - ('accu -> ret) -> - (k * v) list -> - ret = - fun accu kty ty' continue xs -> - match xs with - | [] -> (continue [@ocaml.tailcall]) accu - | (k, v) :: xs -> - (aux' [@ocaml.tailcall]) accu kty k @@ fun accu -> - (aux [@ocaml.tailcall]) accu ty' v @@ fun accu -> - (on_bindings [@ocaml.tailcall]) accu kty ty' continue xs - and aux' : type ret t. 'accu -> t comparable_ty -> t -> ('accu -> ret) -> ret - = - fun accu ty x continue -> - let accu = f.apply_comparable accu ty x in - let next2 ty1 ty2 x1 x2 = - (aux' [@ocaml.tailcall]) accu ty1 x1 @@ fun accu -> - (aux' [@ocaml.tailcall]) accu ty2 x2 @@ fun accu -> - (continue [@ocaml.tailcall]) accu - in - let next ty1 x1 = - (aux' [@ocaml.tailcall]) accu ty1 x1 @@ fun accu -> - (continue [@ocaml.tailcall]) accu - in - let return () = (continue [@ocaml.tailcall]) accu in - match ty with - | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t - | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t - | Bool_t | Chain_id_t | Never_t -> - (return [@ocaml.tailcall]) () - | Pair_t (ty1, ty2, _, YesYes) -> - (next2 [@ocaml.tailcall]) ty1 ty2 (fst x) (snd x) - | Union_t (ty1, ty2, _, YesYes) -> ( - match x with - | L l -> (next [@ocaml.tailcall]) ty1 l - | R r -> (next [@ocaml.tailcall]) ty2 r) - | Option_t (ty, _, Yes) -> ( - match x with - | None -> (return [@ocaml.tailcall]) () - | Some v -> (next [@ocaml.tailcall]) ty v) + (value_traverse_aux [@ocaml.tailcall]) accu ty_value x f @@ fun accu -> + (on_list [@ocaml.tailcall]) ty_value accu xs + in + match[@coq_match_gadt_with_result] (ty_value, x) with + | (Unit_t, _) + | (Int_t, _) + | (Nat_t, _) + | (Signature_t, _) + | (String_t, _) + | (Bytes_t, _) + | (Mutez_t, _) + | (Key_hash_t, _) + | (Key_t, _) + | (Timestamp_t, _) + | (Address_t, _) + | (Tx_rollup_l2_address_t, _) + | (Bool_t, _) + | (Sapling_transaction_t _, _) + | (Sapling_transaction_deprecated_t _, _) + | (Sapling_state_t _, _) + | (Operation_t, _) + | (Chain_id_t, _) + | (Never_t, _) + | (Bls12_381_g1_t, _) + | (Bls12_381_g2_t, _) + | (Bls12_381_fr_t, _) + | (Chest_key_t, _) + | (Chest_t, _) + | (Lambda_t (_, _, _), _) -> + (return [@ocaml.tailcall]) () + | (Pair_t (ty1, ty2, _, _), _) -> + (next2 [@ocaml.tailcall]) + ty1 + ty2 + (fst ((x [@coq_cast]) : _ * _)) + (snd ((x [@coq_cast]) : _ * _)) + | (Union_t (ty1, ty2, _, _), x_value) -> ( + match ((x_value [@coq_cast]) : _ union) with + | L l -> (next [@ocaml.tailcall]) ty1 l + | R r -> (next [@ocaml.tailcall]) ty2 r) + | (Option_t (ty, _, _), x_value) -> ( + match ((x_value [@coq_cast]) : _ option) with + | None -> return () + | Some v -> (next [@ocaml.tailcall]) ty v) + | (Ticket_t (cty, _), _) -> + (value_traverse_aux' [@ocaml.tailcall]) + accu + cty + ((x [@coq_cast]) : _ ticket).contents + f + continue + | (List_t (ty', _), _) -> + on_list ty' accu ((x [@coq_cast]) : _ boxed_list).elements + | (Map_t (kty, ty', _), _) -> + let (Map_tag (module M)) = ((x [@coq_cast]) : (_, _) map) in + let bindings = M.OPS.fold (fun k v bs -> (k, v) :: bs) M.boxed [] in + on_bindings accu kty ty' f continue bindings + | (Set_t (ty', _), _) -> + let (Set_tag (module M)) = ((x [@coq_cast]) : _ set) in + let elements = M.OPS.fold (fun x s -> x :: s) M.boxed [] in + on_list' accu ty' elements f continue + | (Big_map_t (_, _, _), _) -> + (* For big maps, there is no obvious recursion scheme so we + delegate this case to the client. *) + (return [@ocaml.tailcall]) () + | (Contract_t (_, _), _) -> (return [@ocaml.tailcall]) () + +and[@coq_struct "xs"] on_list' : + type ret t. + 'accu -> + t comparable_ty -> + t list -> + 'a value_traverse -> + ('accu -> ret) -> + ret = + fun accu ty' xs f continue -> + match xs with + | [] -> (continue [@ocaml.tailcall]) accu + | x :: xs -> + (value_traverse_aux' [@ocaml.tailcall]) accu ty' x f @@ fun accu -> + (on_list' [@ocaml.tailcall]) accu ty' xs f continue + +and[@coq_struct "xs"] on_bindings : + type ret k v vc. + 'accu -> + k comparable_ty -> + (v, vc) ty -> + 'a value_traverse -> + ('accu -> ret) -> + (k * v) list -> + ret = + fun accu kty ty' f continue xs -> + match xs with + | [] -> (continue [@ocaml.tailcall]) accu + | (k, v) :: xs -> + (value_traverse_aux' [@ocaml.tailcall]) accu kty k f @@ fun accu -> + (value_traverse_aux [@ocaml.tailcall]) accu ty' v f @@ fun accu -> + (on_bindings [@ocaml.tailcall]) accu kty ty' f continue xs + +and[@coq_struct "ty"] value_traverse_aux' : + type ret t. + 'accu -> t comparable_ty -> t -> 'a value_traverse -> ('accu -> ret) -> ret + = + fun accu ty x f continue -> + let accu = f.apply_comparable accu ty x in + let next2 ty1 ty2 x1 x2 = + (value_traverse_aux' [@ocaml.tailcall]) accu ty1 x1 f @@ fun accu -> + (value_traverse_aux' [@ocaml.tailcall]) accu ty2 x2 f @@ fun accu -> + (continue [@ocaml.tailcall]) accu + in + let next ty1 x1 = + (value_traverse_aux' [@ocaml.tailcall]) accu ty1 x1 f @@ fun accu -> + (continue [@ocaml.tailcall]) accu in + let return () = (continue [@ocaml.tailcall]) accu in + match[@coq_match_gadt_with_result] [@coq_match_with_default] (ty, x) with + | (Unit_t, _) + | (Int_t, _) + | (Nat_t, _) + | (Signature_t, _) + | (String_t, _) + | (Bytes_t, _) + | (Mutez_t, _) + | (Key_hash_t, _) + | (Key_t, _) + | (Timestamp_t, _) + | (Address_t, _) + | (Tx_rollup_l2_address_t, _) + | (Bool_t, _) + | (Chain_id_t, _) + | (Never_t, _) -> + (return [@ocaml.tailcall]) () + | (Pair_t (ty1, ty2, _, YesYes), _) -> + (next2 [@ocaml.tailcall]) + ty1 + ty2 + (fst ((x [@coq_cast]) : _ * _)) + (snd ((x [@coq_cast]) : _ * _)) + | (Union_t (ty1, ty2, _, YesYes), x) -> ( + match ((x [@coq_cast]) : _ union) with + | L l -> (next [@ocaml.tailcall]) ty1 l + | R r -> (next [@ocaml.tailcall]) ty2 r) + | (Option_t (ty, _, Yes), x) -> ( + match ((x [@coq_cast]) : _ option) with + | None -> (return [@ocaml.tailcall]) () + | Some v -> (next [@ocaml.tailcall]) ty v) + +let value_traverse (type t tc) (ty : ((t, tc) ty, t comparable_ty) union) + (x : t) init f = match ty with - | L ty -> aux init ty x (fun accu -> accu) - | R cty -> aux' init cty x (fun accu -> accu) - [@@coq_axiom_with_reason "local mutually recursive definition not handled"] + | L ty -> value_traverse_aux init ty x f (fun accu -> accu) + | R cty -> value_traverse_aux' init cty x f (fun accu -> accu) -let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = function +let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = + function[@coq_match_with_default] | Item_t (ty, _) -> Ty_ex_c ty diff --git a/src/proto_013_PtJakart/lib_protocol/script_typed_ir.mli b/src/proto_013_PtJakart/lib_protocol/script_typed_ir.mli index 7d69f8ada1e66..429d6fe12d8de 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_typed_ir.mli +++ b/src/proto_013_PtJakart/lib_protocol/script_typed_ir.mli @@ -174,7 +174,7 @@ type empty_cell = EmptyCell type end_of_stack = empty_cell * empty_cell module Type_size : sig - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:'error_trace Script_tc_errors.error_details -> @@ -254,6 +254,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end (** [map] is made algebraic in order to distinguish it from the other type @@ -322,6 +324,7 @@ type ('arg, 'storage) script = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) script +[@@coq_force_gadt] (* ---- Instructions --------------------------------------------------------*) @@ -1147,6 +1150,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] (* @@ -1394,6 +1398,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1493,6 +1498,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction : { @@ -1554,7 +1560,8 @@ val comparable_ty_size : 'a comparable_ty -> 'a Type_size.t val is_comparable : ('v, 'c) ty -> 'c dbool -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] val unit_key : unit comparable_ty diff --git a/src/proto_013_PtJakart/lib_protocol/script_typed_ir_size.ml b/src/proto_013_PtJakart/lib_protocol/script_typed_ir_size.ml index 7cf303d552bf3..a9a51a40e717b 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_typed_ir_size.ml @@ -32,19 +32,20 @@ let script_string_size s = Script_string.to_string s |> string_size (* Memo-sizes are 16-bit integers *) let sapling_memo_size_size = !!0 -let ty_traverse_f = - let base_basic = - !!0 - (* Basic types count for 0 because they are all static values, hence shared - and not counted by `reachable_words`. - On the other hand compound types are functions, hence not shared. *) - in - let base_compound_no_meta = header_size in - let base_compound _meta = h1w in +module Ty_size = struct + let base_basic = !!0 + + (* Basic types count for 0 because they are all static values, hence shared + and not counted by `reachable_words`. + On the other hand compound types are functions, hence not shared. *) + let base_compound_no_meta = header_size + + let base_compound _meta = h1w + let apply_comparable : type a. nodes_and_size -> a comparable_ty -> nodes_and_size = fun accu cty -> - match cty with + match[@coq_match_with_default] cty with | Unit_t -> ret_succ_adding accu base_basic | Int_t -> ret_succ_adding accu base_basic | Nat_t -> ret_succ_adding accu base_basic @@ -66,7 +67,8 @@ let ty_traverse_f = ret_succ_adding accu @@ (base_compound a +! (word_size *? 3)) | Option_t (_ty, a, Yes) -> ret_succ_adding accu @@ (base_compound a +! (word_size *? 2)) - and apply : type a ac. nodes_and_size -> (a, ac) ty -> nodes_and_size = + + let apply : type a ac. nodes_and_size -> (a, ac) ty -> nodes_and_size = fun accu ty -> match ty with | Unit_t -> ret_succ_adding accu base_basic @@ -117,14 +119,14 @@ let ty_traverse_f = @@ (base_compound_no_meta +! sapling_memo_size_size +! word_size) | Ticket_t (_cty, a) -> ret_succ_adding accu @@ (base_compound a +! word_size) - in - ({apply; apply_comparable} : nodes_and_size ty_traverse) -let comparable_ty_size : type a. a comparable_ty -> nodes_and_size = - fun cty -> comparable_ty_traverse cty zero ty_traverse_f + let f = ({apply; apply_comparable} : nodes_and_size ty_traverse) +end + +let comparable_ty_size cty = comparable_ty_traverse cty zero Ty_size.f let ty_size : type a ac. (a, ac) ty -> nodes_and_size = - fun ty -> ty_traverse ty zero ty_traverse_f + fun ty -> ty_traverse ty zero Ty_size.f let stack_ty_size s = let apply : type a s. nodes_and_size -> (a, s) stack_ty -> nodes_and_size = @@ -232,7 +234,7 @@ let kinfo_size {iloc = _; kstack_ty = _} = h2w tail-recursive and the only recursive call that is not a tailcall cannot be nested. (See [big_map_size].) For this reason, these functions should not trigger stack overflows. *) -let rec value_size : +let[@coq_struct "ty"] rec value_size_aux : type a ac. count_lambda_nodes:bool -> nodes_and_size -> @@ -242,90 +244,111 @@ let rec value_size : fun ~count_lambda_nodes accu ty x -> let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size = fun accu ty x -> - match ty with - | Unit_t -> ret_succ accu - | Int_t -> ret_succ_adding accu (script_int_size x) - | Nat_t -> ret_succ_adding accu (script_nat_size x) - | Signature_t -> ret_succ_adding accu signature_size - | String_t -> ret_succ_adding accu (script_string_size x) - | Bytes_t -> ret_succ_adding accu (bytes_size x) - | Mutez_t -> ret_succ_adding accu mutez_size - | Key_hash_t -> ret_succ_adding accu (key_hash_size x) - | Key_t -> ret_succ_adding accu (public_key_size x) - | Timestamp_t -> ret_succ_adding accu (timestamp_size x) - | Address_t -> ret_succ_adding accu (address_size x) - | Tx_rollup_l2_address_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with + | (Unit_t, _) -> ret_succ accu + | (Int_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_int_size x) + | (Nat_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_nat_size x) + | (Signature_t, _) -> ret_succ_adding accu signature_size + | (String_t, (x : Script_string.t)) -> + ret_succ_adding accu (script_string_size x) + | (Bytes_t, (x : bytes)) -> ret_succ_adding accu (bytes_size x) + | (Mutez_t, _) -> ret_succ_adding accu mutez_size + | (Key_hash_t, (x : public_key_hash)) -> + ret_succ_adding accu (key_hash_size x) + | (Key_t, (x : public_key)) -> ret_succ_adding accu (public_key_size x) + | (Timestamp_t, (x : Script_timestamp.t)) -> + ret_succ_adding accu (timestamp_size x) + | (Address_t, (x : address)) -> ret_succ_adding accu (address_size x) + | (Tx_rollup_l2_address_t, (x : tx_rollup_l2_address)) -> ret_succ_adding accu (tx_rollup_l2_address_size x) - | Bool_t -> ret_succ accu - | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w - | Union_t (_, _, _, _) -> ret_succ_adding accu h1w - | Lambda_t (_, _, _) -> - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x - | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) - | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length)) - | Set_t (_, _) -> - let module M = (val Script_set.get x) in + | (Bool_t, _) -> ret_succ accu + | (Pair_t (_, _, _, _), _) -> ret_succ_adding accu h2w + | (Union_t (_, _, _, _), _) -> ret_succ_adding accu h1w + | (Lambda_t (_, _, _), (x : _ lambda)) -> + (lambda_size_aux [@ocaml.tailcall]) + ~count_lambda_nodes + (ret_succ accu) + x + | (Option_t (_, _, _), (x : _ option)) -> + ret_succ_adding accu (option_size (fun _ -> !!0) x) + | (List_t (_, _), (x : _ boxed_list)) -> + ret_succ_adding accu (h2w +! (h2w *? x.length)) + | (Set_t (_, _), (x : _ set)) -> + let set = Script_set.get x in + let module M = (val set) in let boxing_space = !!536 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h4w *? M.size)) - | Map_t (_, _, _) -> - let module M = (val Script_map.get_module x) in + | (Map_t (_, _, _), (x : _ map)) -> + let map = Script_map.get_module x in + let module M = (val map) in let boxing_space = !!696 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h5w *? M.size)) - | Big_map_t (cty, ty', _) -> - (big_map_size [@ocaml.tailcall]) + | (Big_map_t (cty, ty', _), (x : _ big_map)) -> + (big_map_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) cty ty' x - | Contract_t (_, _) -> ret_succ (accu ++ contract_size x) - | Sapling_transaction_t _ -> + | (Contract_t (_, _), (x : _ typed_contract)) -> + ret_succ (accu ++ contract_size x) + | (Sapling_transaction_t _, (x : Sapling.transaction)) -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) - | Sapling_transaction_deprecated_t _ -> + | (Sapling_transaction_deprecated_t _, (x : Sapling_repr.legacy_transaction)) + -> ret_succ_adding accu (Sapling.Legacy.transaction_in_memory_size x) - | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x) + | (Sapling_state_t _, (x : Sapling.state)) -> + ret_succ_adding accu (sapling_state_size x) (* Operations are neither storable nor pushable, so they can appear neither in the storage nor in the script. Hence they cannot appear in the cache and we never need to measure their size. *) - | Operation_t -> assert false - | Chain_id_t -> ret_succ_adding accu chain_id_size - | Never_t -> ( match x with _ -> .) - | Bls12_381_g1_t -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory - | Bls12_381_g2_t -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory - | Bls12_381_fr_t -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory - | Ticket_t (_, _) -> ret_succ_adding accu (ticket_size x) - | Chest_key_t -> ret_succ_adding accu (chest_key_size x) - | Chest_t -> ret_succ_adding accu (chest_size x) + | (Operation_t, _) -> assert false + | (Chain_id_t, _) -> ret_succ_adding accu chain_id_size + | (Never_t, _) -> . + | (Bls12_381_g1_t, _) -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory + | (Bls12_381_g2_t, _) -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory + | (Bls12_381_fr_t, _) -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory + | (Ticket_t (_, _), (x : _ ticket)) -> ret_succ_adding accu (ticket_size x) + | (Chest_key_t, (x : Script_timelock.chest_key)) -> + ret_succ_adding accu (chest_key_size x) + | (Chest_t, (x : Script_timelock.chest)) -> + ret_succ_adding accu (chest_size x) in let apply_comparable : type a. nodes_and_size -> a comparable_ty -> a -> nodes_and_size = fun accu ty x -> - match ty with - | Unit_t -> ret_succ accu - | Int_t -> ret_succ_adding accu (script_int_size x) - | Nat_t -> ret_succ_adding accu (script_nat_size x) - | Signature_t -> ret_succ_adding accu signature_size - | String_t -> ret_succ_adding accu (script_string_size x) - | Bytes_t -> ret_succ_adding accu (bytes_size x) - | Mutez_t -> ret_succ_adding accu mutez_size - | Key_hash_t -> ret_succ_adding accu (key_hash_size x) - | Key_t -> ret_succ_adding accu (public_key_size x) - | Timestamp_t -> ret_succ_adding accu (timestamp_size x) - | Address_t -> ret_succ_adding accu (address_size x) - | Tx_rollup_l2_address_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with + | (Unit_t, _) -> ret_succ accu + | (Int_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_int_size x) + | (Nat_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_nat_size x) + | (Signature_t, _) -> ret_succ_adding accu signature_size + | (String_t, (x : Script_string.t)) -> + ret_succ_adding accu (script_string_size x) + | (Bytes_t, (x : bytes)) -> ret_succ_adding accu (bytes_size x) + | (Mutez_t, _) -> ret_succ_adding accu mutez_size + | (Key_hash_t, (x : public_key_hash)) -> + ret_succ_adding accu (key_hash_size x) + | (Key_t, (x : public_key)) -> ret_succ_adding accu (public_key_size x) + | (Timestamp_t, (x : Script_timestamp.t)) -> + ret_succ_adding accu (timestamp_size x) + | (Address_t, (x : address)) -> ret_succ_adding accu (address_size x) + | (Tx_rollup_l2_address_t, (x : tx_rollup_l2_address)) -> ret_succ_adding accu (tx_rollup_l2_address_size x) - | Bool_t -> ret_succ accu - | Pair_t (_, _, _, YesYes) -> ret_succ_adding accu h2w - | Union_t (_, _, _, YesYes) -> ret_succ_adding accu h1w - | Option_t (_, _, Yes) -> + | (Bool_t, _) -> ret_succ accu + | (Pair_t (_, _, _, _), _) -> ret_succ_adding accu h2w + | (Union_t (_, _, _, YesYes), _) -> ret_succ_adding accu h1w + | (Option_t (_, _, Yes), (x : _ option)) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) - | Chain_id_t -> ret_succ_adding accu chain_id_size - | Never_t -> ( match x with _ -> .) + | (Chain_id_t, _) -> ret_succ_adding accu chain_id_size + | (Never_t, _) -> . in value_traverse ty x accu {apply; apply_comparable} - [@@coq_axiom_with_reason "unreachable expressions '.' not handled for now"] -and big_map_size : +and[@coq_mutual_as_notation] big_map_size_aux : type a b bc. count_lambda_nodes:bool -> nodes_and_size -> @@ -345,12 +368,12 @@ and big_map_size : (* The following recursive call cannot introduce a stack overflow because this would require a key of type big_map while big_map is not comparable. *) - let accu = value_size ~count_lambda_nodes accu (R cty) key in + let accu = value_size_aux ~count_lambda_nodes accu (R cty) key in match value with | None -> accu | Some value -> let accu = ret_succ_adding accu h1w in - (value_size [@ocaml.tailcall]) + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu (L ty') @@ -366,7 +389,7 @@ and big_map_size : (comparable_ty_size key_type ++ ty_size value_type ++ diff_size) (h4w +! id_size) -and lambda_size : +and[@coq_struct "function_parameter"] lambda_size_aux : type i o. count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size = @@ -376,9 +399,9 @@ and lambda_size : let accu = ret_adding (accu ++ if count_lambda_nodes then node_size node else zero) h2w in - (kdescr_size [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr + (kdescr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr -and kdescr_size : +and[@coq_mutual_as_notation] kdescr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -388,9 +411,9 @@ and kdescr_size : let accu = ret_adding (accu ++ stack_ty_size kbef ++ stack_ty_size kaft) h4w in - (kinstr_size [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr + (kinstr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr -and kinstr_size : +and[@coq_struct "t_value"] kinstr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -408,7 +431,7 @@ and kinstr_size : | IConst (kinfo, x, k) -> let accu = ret_succ_adding accu (base kinfo +! word_size) in let (Ty_ex_c top_ty) = stack_top_ty (kinfo_of_kinstr k).kstack_ty in - (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu (L top_ty) x + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu (L top_ty) x | ICons_pair (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICar (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICdr (kinfo, _) -> ret_succ_adding accu (base kinfo) @@ -503,7 +526,7 @@ and kinstr_size : ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size) | ILambda (kinfo, lambda, _) -> let accu = ret_succ_adding accu (base kinfo +! word_size) in - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes accu lambda + (lambda_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu lambda | IFailwith (kinfo, _, ty) -> ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size) | ICompare (kinfo, cty, _) -> @@ -656,20 +679,25 @@ let rec kinstr_extra_size : type a s r f. (a, s, r, f) kinstr -> nodes_and_size [ty_of_comparable_ty] to create a type that is embedded in the IR. *) | ITicket (_, k) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr k in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | IRead_ticket (_, k) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr k in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | ICompare (_, ty, _) -> comparable_ty_size ty | ISet_iter (_, body, _) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr body in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | IMap_map (_, body, _) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr body in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | IMap_iter (_, body, _) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr body in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | ILambda (_, lambda, _) -> lambda_extra_size lambda | _ -> zero in @@ -688,7 +716,7 @@ let lambda_size lam = *) let (lambda_nodes, lambda_size) = - lambda_size ~count_lambda_nodes:true zero lam + lambda_size_aux ~count_lambda_nodes:true zero lam in let (lambda_extra_size_nodes, lambda_extra_size) = lambda_extra_size lam in let size = (lambda_size *? 157 /? 100) +! (lambda_extra_size *? 18 /? 100) in @@ -697,12 +725,12 @@ let lambda_size lam = let kinstr_size kinstr = let (kinstr_extra_size_nodes, kinstr_extra_size) = kinstr_extra_size kinstr in let (kinstr_nodes, kinstr_size) = - kinstr_size ~count_lambda_nodes:true zero kinstr + kinstr_size_aux ~count_lambda_nodes:true zero kinstr in let size = (kinstr_size *? 157 /? 100) +! (kinstr_extra_size *? 18 /? 100) in (Nodes.add kinstr_nodes kinstr_extra_size_nodes, size) -let value_size ty x = value_size ~count_lambda_nodes:true zero (L ty) x +let value_size ty x = value_size_aux ~count_lambda_nodes:true zero (L ty) x module Internal_for_tests = struct let ty_size = ty_size diff --git a/src/proto_013_PtJakart/lib_protocol/seed_repr.ml b/src/proto_013_PtJakart/lib_protocol/seed_repr.ml index b9f6d85160c85..bc8c2dec03c06 100644 --- a/src/proto_013_PtJakart/lib_protocol/seed_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/seed_repr.ml @@ -78,7 +78,7 @@ let take_int32 s bound = let drop_if_over = Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let (bytes, s) = take s in let r = TzEndian.get_int32 bytes 0 in (* The absolute value of min_int is min_int. Also, every @@ -101,7 +101,7 @@ let take_int64 s bound = Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let (bytes, s) = take s in let r = TzEndian.get_int64 bytes 0 in (* The absolute value of min_int is min_int. Also, every @@ -153,7 +153,7 @@ let initial_nonce_hash_0 = hash initial_nonce_0 let deterministic_seed seed = nonce seed zero_bytes let initial_seeds ?initial_seed n = - let[@coq_struct "i"] rec loop acc elt i = + let[@coq_struct "i_value"] rec loop acc elt i = if Compare.Int.(i = 1) then List.rev (elt :: acc) else loop (elt :: acc) (deterministic_seed elt) (i - 1) in diff --git a/src/proto_013_PtJakart/lib_protocol/services_registration.ml b/src/proto_013_PtJakart/lib_protocol/services_registration.ml index de94c5dbdf695..4fa5d81a2d9c3 100644 --- a/src/proto_013_PtJakart/lib_protocol/services_registration.ml +++ b/src/proto_013_PtJakart/lib_protocol/services_registration.ml @@ -31,12 +31,14 @@ type rpc_context = { context : Alpha_context.t; } +type level = Head_level | Successor_level + let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) mode = let timestamp = block_header.timestamp in let level = match mode with - | `Head_level -> block_header.level - | `Successor_level -> Int32.succ block_header.level + | Head_level -> block_header.level + | Successor_level -> Int32.succ block_header.level in Alpha_context.prepare ~level @@ -51,7 +53,7 @@ let rpc_services = let register0_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -63,7 +65,7 @@ let register0_noctxt ~chunked s f = let register1_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -75,7 +77,7 @@ let register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -84,7 +86,7 @@ let register2 ~chunked s f = let opt_register0_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = opt_register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -92,7 +94,7 @@ let opt_register0 ~chunked s f = let opt_register1_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let opt_register1 ~chunked s f = opt_register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -104,7 +106,7 @@ let opt_register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let opt_register2 ~chunked s f = opt_register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -114,7 +116,7 @@ let get_rpc_services () = let p = RPC_directory.map (fun c -> - rpc_init c `Head_level >|= function + rpc_init c Head_level >|= function | Error t -> raise (Failure (Format.asprintf "%a" Error_monad.pp_trace t)) | Ok c -> c.context) diff --git a/src/proto_013_PtJakart/lib_protocol/services_registration.mli b/src/proto_013_PtJakart/lib_protocol/services_registration.mli index c6bc2ed72c92a..da7faca5500a2 100644 --- a/src/proto_013_PtJakart/lib_protocol/services_registration.mli +++ b/src/proto_013_PtJakart/lib_protocol/services_registration.mli @@ -44,6 +44,8 @@ type rpc_context = { context : t; } +type level = Head_level | Successor_level + (** [rpc_init rpc_context mode] allows to instantiate an [rpc_context] using the [Alpha_context] representation from a raw context representation (the one the shell knows). @@ -60,9 +62,7 @@ type rpc_context = { paths depend on the level. Using the successor level allows to ensure that the simulation is done on a fresh level. *) val rpc_init : - Updater.rpc_context -> - [`Head_level | `Successor_level] -> - rpc_context Error_monad.tzresult Lwt.t + Updater.rpc_context -> level -> rpc_context Error_monad.tzresult Lwt.t val register0 : chunked:bool -> diff --git a/src/proto_013_PtJakart/lib_protocol/skip_list_repr.ml b/src/proto_013_PtJakart/lib_protocol/skip_list_repr.ml index 3a5a221d34fc7..568835d9d04a5 100644 --- a/src/proto_013_PtJakart/lib_protocol/skip_list_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/skip_list_repr.ml @@ -26,6 +26,13 @@ module type S = sig type ('content, 'ptr) cell + val pp : + pp_content:(Format.formatter -> 'content -> unit) -> + pp_ptr:(Format.formatter -> 'ptr -> unit) -> + Format.formatter -> + ('content, 'ptr) cell -> + unit + val equal : ('content -> 'content -> bool) -> ('ptr -> 'ptr -> bool) -> @@ -38,7 +45,7 @@ module type S = sig 'content Data_encoding.t -> ('content, 'ptr) cell Data_encoding.t - val index : (_, _) cell -> int + val index : ('content, 'ptr) cell -> int val content : ('content, 'ptr) cell -> 'content @@ -69,9 +76,11 @@ module type S = sig bool end -module Make (Parameters : sig +module type S_Parameters = sig val basis : int -end) : S = struct +end + +module Make (Parameters : S_Parameters) : S = struct let () = assert (Compare.Int.(Parameters.basis >= 2)) open Parameters @@ -122,8 +131,8 @@ end) : S = struct in let {content; back_pointers; index} = cell1 in equal_content content cell2.content - && equal_back_pointers back_pointers cell2.back_pointers && Compare.Int.equal index cell2.index + && equal_back_pointers back_pointers cell2.back_pointers let index cell = cell.index @@ -136,6 +145,20 @@ end) : S = struct [] |> List.rev + let pp ~pp_content ~pp_ptr fmt {content; back_pointers; index} = + Format.fprintf + fmt + {| + content = %a + index = %d + back_pointers = %a + |} + pp_content + content + index + (Format.pp_print_list pp_ptr) + (back_pointers_to_list back_pointers) + let encoding ptr_encoding content_encoding = let of_list = FallbackArray.of_list ~fallback:None ~proj:(fun c -> Some c) @@ -167,10 +190,14 @@ end) : S = struct | Some ptr -> ptr | None -> (* By precondition and invariants of cells. *) assert false + (* Show that the values in the resulting [back_pointers] array have the + following values: {idx_index(idx) | 0 <= idx <= log(index, basis)} + *) + (* Also show that [idx_index(idx)] is an increasing function. *) let next ~prev_cell ~prev_cell_ptr content = let index = prev_cell.index + 1 in let back_pointers = - let rec aux power accu i = + let[@coq_struct "power"] rec aux power accu i = if Compare.Int.(index < power) then List.rev accu else let back_pointer_i = @@ -188,43 +215,46 @@ end) : S = struct aux 1 [] 0 in let back_pointers = - FallbackArray.of_list ~fallback:None ~proj:(fun x -> Some x) back_pointers + FallbackArray.of_list ~fallback:None ~proj:Option.some back_pointers in {index; content; back_pointers} + (* Show that: + * We always return something (when the target index is smaller that the + cell index), as there is at least the first [idx] that gives a [Some ...] + * the resulting idx verifies that [target_index] <= [idx_index(idx)] < [cell.index] + *) let best_skip cell target_index = let index = cell.index in - let rec aux idx pow best_idx best_skip = + let[@coq_struct "idx"] rec aux idx pow best_idx = if Compare.Int.(idx >= FallbackArray.length cell.back_pointers) then best_idx else let idx_index = index - (index mod pow) - 1 in - let skip = index - idx_index in - if - Compare.Int.(idx_index < target_index) - || Option.equal Compare.Int.equal (Some skip) best_skip - then best_idx - else aux (idx + 1) (basis * pow) (Some idx) (Some skip) + if Compare.Int.(idx_index < target_index) then best_idx + else aux (idx + 1) (basis * pow) (Some idx) in - aux 0 1 None None + aux 0 1 None let back_path ~deref ~cell_ptr ~target_index = - let rec aux path ptr = + let[@coq_struct "cell_value"] rec aux path ptr cell = let path = ptr :: path in - Option.bind (deref ptr) @@ fun cell -> + Option.bind cell @@ fun cell -> let index = cell.index in if Compare.Int.(target_index = index) then Some (List.rev path) else if Compare.Int.(target_index > index) then None else Option.bind (best_skip cell target_index) @@ fun best_idx -> - Option.bind (back_pointer cell best_idx) @@ fun ptr -> aux path ptr + Option.bind (back_pointer cell best_idx) @@ fun ptr -> + aux path ptr (deref ptr) in - aux [] cell_ptr + aux [] cell_ptr (deref cell_ptr) + (* Show that this checks for membership *) let mem equal x l = let open FallbackArray in let n = length l in - let rec aux idx = + let[@coq_struct "idx"] rec aux idx = if Compare.Int.(idx >= n) then false else match FallbackArray.get l idx with @@ -235,11 +265,14 @@ end) : S = struct let assume_some o f = match o with None -> false | Some x -> f x + (* Try to first show the validity of this function considering [best_skip] as + abstract, maybe with a few properties attached to it. *) + (* Also: re-compile the project with the last changes from Edwin. *) let valid_back_path ~equal_ptr ~deref ~cell_ptr ~target_ptr path = assume_some (deref target_ptr) @@ fun target -> assume_some (deref cell_ptr) @@ fun cell -> let target_index = index target and cell_index = index cell in - let rec valid_path index cell_ptr path = + let[@coq_struct "path"] rec valid_path index cell_ptr path = match (cell_ptr, path) with | (final_cell, []) -> equal_ptr target_ptr final_cell && Compare.Int.(index = target_index) diff --git a/src/proto_013_PtJakart/lib_protocol/skip_list_repr.mli b/src/proto_013_PtJakart/lib_protocol/skip_list_repr.mli index 843003e18a151..52b13636bd17c 100644 --- a/src/proto_013_PtJakart/lib_protocol/skip_list_repr.mli +++ b/src/proto_013_PtJakart/lib_protocol/skip_list_repr.mli @@ -51,6 +51,13 @@ module type S = sig pointers of type ['ptr]. *) type ('content, 'ptr) cell + val pp : + pp_content:(Format.formatter -> 'content -> unit) -> + pp_ptr:(Format.formatter -> 'ptr -> unit) -> + Format.formatter -> + ('content, 'ptr) cell -> + unit + val equal : ('content -> 'content -> bool) -> ('ptr -> 'ptr -> bool) -> @@ -112,6 +119,8 @@ module type S = sig bool end -module Make (_ : sig +module type S_Parameters = sig val basis : int -end) : S +end + +module Make (_ : S_Parameters) : S diff --git a/src/proto_013_PtJakart/lib_protocol/slot_repr.ml b/src/proto_013_PtJakart/lib_protocol/slot_repr.ml index 4cb7219bfedc2..338df1a6d3e22 100644 --- a/src/proto_013_PtJakart/lib_protocol/slot_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/slot_repr.ml @@ -84,21 +84,21 @@ module Range = struct ok (Interval {lo = min; hi = max}) let fold f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then acc else loop ~acc:(f acc next) ~next:(next + 1) in loop ~acc:(f init lo) ~next:(lo + 1) let fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next + 1) in f init lo >>=? fun acc -> loop ~acc ~next:(lo + 1) let rev_fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next < lo) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next - 1) in diff --git a/src/proto_013_PtJakart/lib_protocol/storage.ml b/src/proto_013_PtJakart/lib_protocol/storage.ml index 4df9084d801e4..d808bd6172056 100644 --- a/src/proto_013_PtJakart/lib_protocol/storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/storage.ml @@ -93,7 +93,7 @@ module type Simple_single_data_storage = sig end module Block_round : Simple_single_data_storage with type value = Round_repr.t = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["block_round"] end) @@ -101,14 +101,14 @@ module Block_round : Simple_single_data_storage with type value = Round_repr.t = module Tenderbake = struct module First_level_legacy = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["first_level_of_Tenderbake"] end) (Raw_level_repr) module First_level_of_protocol = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["first_level_of_protocol"] end) @@ -125,14 +125,14 @@ module Tenderbake = struct end module Endorsement_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["endorsement_branch"] end) (Branch) module Grand_parent_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["grand_parent_branch"] end) @@ -171,7 +171,7 @@ end module Contract = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["contracts"] end) @@ -397,7 +397,7 @@ module Global_constants = struct and type key = Script_expr_hash.t and type value = Script_repr.expr = Make_indexed_carbonated_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["global_constant"] end)) @@ -415,7 +415,7 @@ module Big_map = struct type id = Lazy_storage_kind.Big_map.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["big_maps"] end) @@ -550,7 +550,7 @@ module Sapling = struct type id = Lazy_storage_kind.Sapling_state.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sapling"] end) @@ -906,7 +906,7 @@ end module Delegates = Make_data_set_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["delegates"] end)) @@ -932,7 +932,7 @@ end module Cycle = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["cycle"] end)) @@ -1047,7 +1047,7 @@ module Slashed_deposits = Cycle.Slashed_deposits module Stake = struct module Staking_balance = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["staking_balance"] end)) @@ -1057,7 +1057,7 @@ module Stake = struct module Active_delegate_with_one_roll = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["active_delegate_with_one_roll"] end)) @@ -1087,7 +1087,7 @@ module Stake = struct The ratio above (blocks_per_cycle / blocks_per_stake_snapshot) is checked in {!val:Constants_repr.check_constants} to fit in a UInt16. *) module Last_snapshot = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["last_snapshot"] end) @@ -1101,7 +1101,7 @@ module Delegate_sampler_state = Cycle.Delegate_sampler_state module Vote = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["votes"] end) @@ -1268,7 +1268,7 @@ end module Commitments = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["commitments"] end)) @@ -1286,7 +1286,7 @@ module Ramp_up = struct module Rewards = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["ramp_up"; "rewards"] end)) @@ -1322,7 +1322,7 @@ end module Pending_migration = struct module Balance_updates = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_balance_updates"] end) @@ -1333,7 +1333,7 @@ module Pending_migration = struct end) module Operation_results = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_operation_results"] end) @@ -1368,7 +1368,7 @@ end module Liquidity_baking = struct module Toggle_ema = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct (* The old "escape" name is kept here to avoid migrating this. *) let name = ["liquidity_baking_escape_ema"] @@ -1376,7 +1376,7 @@ module Liquidity_baking = struct (Encoding.Int32) module Cpmm_address = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["liquidity_baking_cpmm_address"] end) @@ -1388,7 +1388,7 @@ module Ticket_balance = struct let name = ["ticket_balance"] end - module Raw_context = Make_subcontext (Registered) (Raw_context) (Name) + module Raw_context = Make_subcontext (Registered) (Raw_context.M) (Name) module Paid_storage_space = Make_single_data_storage (Registered) (Raw_context) @@ -1411,14 +1411,19 @@ module Ticket_balance = struct end) module Index = Make_index (Ticket_hash_repr.Index) - module Table = + + module Table : + Non_iterable_indexed_carbonated_data_storage + with type t := Raw_context.t + and type key = Ticket_hash_repr.t + and type value = Z.t = Make_indexed_carbonated_data_storage (Table_context) (Index) (Encoding.Z) end module Tx_rollup = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["tx_rollup"] end)) @@ -1486,7 +1491,7 @@ end module Sc_rollup = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sc_rollup"] end) @@ -1554,7 +1559,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_repr.Commitment_hash.encoding end) - module Stakers = + module Stakers : + Non_iterable_indexed_carbonated_data_storage + with type key = Signature.Public_key_hash.t + and type value = Sc_rollup_repr.Commitment_hash.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1578,7 +1587,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitments = + module Commitments : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_repr.Commitment_hash.t + and type value = Sc_rollup_repr.Commitment.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1591,7 +1604,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_repr.Commitment.encoding end) - module Commitment_stake_count = + module Commitment_stake_count : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_repr.Commitment_hash.t + and type value = int32 + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1604,7 +1621,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitment_added = + module Commitment_added : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_repr.Commitment_hash.t + and type value = Raw_level_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct diff --git a/src/proto_013_PtJakart/lib_protocol/storage_description.ml b/src/proto_013_PtJakart/lib_protocol/storage_description.ml index 7bac72c5a9690..b237f232b9948 100644 --- a/src/proto_013_PtJakart/lib_protocol/storage_description.ml +++ b/src/proto_013_PtJakart/lib_protocol/storage_description.ml @@ -124,35 +124,38 @@ type (_, _, _) args = ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args -let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function +let[@coq_struct "function_parameter"] rec unpack : + type a b c. (a, b, c) args -> c -> a * b = + function[@coq_match_gadt_with_result] | One _ -> fun x -> x | Pair (l, r) -> - let unpack_l = unpack l in - let unpack_r = unpack r in + let unpack_l = (unpack [@coq_type_annotation]) l in + let unpack_r = (unpack [@coq_type_annotation]) r in fun x -> let (c, d) = unpack_r x in let (b, a) = unpack_l c in (b, (a, d)) - [@@coq_axiom_with_reason "gadt"] -let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function +let[@coq_struct "function_parameter"] rec pack : + type a b c. (a, b, c) args -> a -> b -> c = + function[@coq_match_gadt_with_result] | One _ -> fun b a -> (b, a) | Pair (l, r) -> - let pack_l = pack l in - let pack_r = pack r in + let pack_l = (pack [@coq_type_annotation]) l in + let pack_r = (pack [@coq_type_annotation]) r in fun b (a, d) -> let c = pack_l b a in pack_r c d - [@@coq_axiom_with_reason "gadt"] -let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function - | One {compare; _} -> compare +let[@coq_struct "function_parameter"] rec compare : + type a b c. (a, b, c) args -> b -> b -> int = + function[@coq_match_gadt_with_result] + | One {compare = local_compare; _} -> local_compare | Pair (l, r) -> ( let compare_l = compare l in let compare_r = compare r in fun (a1, b1) (a2, b2) -> match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x) - [@@coq_axiom_with_reason "gadt"] let destutter equal l = match l with @@ -164,12 +167,12 @@ let destutter equal l = in loop [i] i l -let rec register_indexed_subcontext : +let[@coq_struct "desc"] rec register_indexed_subcontext : type r a b. r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t = fun desc ~list path -> - match path with - | Pair (left, right) -> + match[@coq_match_gadt] (path, desc, list) with + | (Pair (left, right), desc, (list : _ -> (_ * _) list tzresult Lwt.t)) -> let compare_left = compare left in let equal_left x y = Compare.Int.(compare_left x y = 0) in let list_left r = list r >|=? fun l -> destutter equal_left l in @@ -182,7 +185,7 @@ let rec register_indexed_subcontext : (register_indexed_subcontext desc ~list:list_left left) ~list:list_right right - | One {rpc_arg = arg; encoding = arg_encoding; _} -> ( + | (One {rpc_arg = arg; encoding = arg_encoding; _}, desc, list) -> ( match desc.dir with | Value _ | NamedDir _ -> Format.kasprintf @@ -203,7 +206,7 @@ let rec register_indexed_subcontext : } in desc.dir <- IndexedDir {arg; arg_encoding; list; subdir} ; - subdir + ((subdir [@coq_cast]) : b t) | IndexedDir {arg = inner_arg; subdir; _} -> ( match RPC_arg.eq arg inner_arg with | None -> @@ -215,8 +218,7 @@ let rec register_indexed_subcontext : desc.rev_path (RPC_arg.descr arg).name (RPC_arg.descr inner_arg).name - | Some RPC_arg.Eq -> subdir)) - [@@coq_axiom_with_reason "gadt"] + | Some RPC_arg.Eq -> ((subdir [@coq_cast]) : b t))) let register_value : type a b. @@ -247,14 +249,14 @@ module type INDEX = sig val compare : t -> t -> int end -type _ handler = +type 'key handler = | Handler : { encoding : 'a Data_encoding.t; get : 'key -> int -> 'a tzresult Lwt.t; } -> 'key handler -type _ opt_handler = +type 'key opt_handler = | Opt_handler : { encoding : 'a Data_encoding.t; get : 'key -> int -> 'a option tzresult Lwt.t; @@ -277,7 +279,6 @@ let rec combine_object = function handler.get k i >>=? fun v1 -> handlers.get k i >|=? fun v2 -> (v1, v2)); } - [@@coq_axiom_with_reason "gadt"] type query = {depth : int} @@ -301,10 +302,10 @@ let build_directory : type key. key t -> key RPC_directory.t = RPC_directory.opt_register ~chunked !rpc_dir service (fun k q () -> get k (q.depth + 1)) in - let rec build_handler : + let[@coq_struct "desc"] rec build_handler : type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler = fun desc path -> - match desc.dir with + match[@coq_match_gadt] desc.dir with | Empty -> Opt_handler {encoding = Data_encoding.unit; get = (fun _ _ -> return_none)} @@ -340,49 +341,49 @@ let build_directory : type key. key t -> key RPC_directory.t = in register ~chunked:true path handler ; handler - | IndexedDir {arg; arg_encoding; list; subdir} -> - let (Opt_handler handler) = - build_handler subdir RPC_path.(path /: arg) - in - let encoding = - let open Data_encoding in - union - [ - case - (Tag 0) - ~title:"Leaf" - (dynamic_size arg_encoding) - (function (key, None) -> Some key | _ -> None) - (fun key -> (key, None)); - case - (Tag 1) - ~title:"Dir" - (tup2 - (dynamic_size arg_encoding) - (dynamic_size handler.encoding)) - (function (key, Some value) -> Some (key, value) | _ -> None) - (fun (key, value) -> (key, Some value)); - ] - in - let get k i = - if Compare.Int.(i < 0) then return_none - else if Compare.Int.(i = 0) then return_some [] - else - list k >>=? fun keys -> - List.map_es - (fun key -> - if Compare.Int.(i = 1) then return (key, None) - else handler.get (k, key) (i - 1) >|=? fun value -> (key, value)) - keys - >>=? fun values -> return_some values - in - let handler = - Opt_handler - {encoding = Data_encoding.(list (dynamic_size encoding)); get} - in - register ~chunked:true path handler ; - handler + | IndexedDir {arg; arg_encoding; list; subdir} -> ( + match[@coq_match_gadt] build_handler subdir RPC_path.(path /: arg) with + | Opt_handler handler -> + let encoding = + let open Data_encoding in + union + [ + case + (Tag 0) + ~title:"Leaf" + (dynamic_size arg_encoding) + (function (key, None) -> Some key | _ -> None) + (fun key -> (key, None)); + case + (Tag 1) + ~title:"Dir" + (tup2 + (dynamic_size arg_encoding) + (dynamic_size handler.encoding)) + (function + | (key, Some value) -> Some (key, value) | _ -> None) + (fun (key, value) -> (key, Some value)); + ] + in + let get k i = + if Compare.Int.(i < 0) then return_none + else if Compare.Int.(i = 0) then return_some [] + else + list k >>=? fun keys -> + List.map_es + (fun key -> + if Compare.Int.(i = 1) then return (key, None) + else + handler.get (k, key) (i - 1) >|=? fun value -> (key, value)) + keys + >>=? fun values -> return_some values + in + let handler = + Opt_handler + {encoding = Data_encoding.(list (dynamic_size encoding)); get} + in + register ~chunked:true path handler ; + handler) in ignore (build_handler dir RPC_path.open_root : key opt_handler) ; !rpc_dir - [@@coq_axiom_with_reason "gadt"] diff --git a/src/proto_013_PtJakart/lib_protocol/storage_functors.ml b/src/proto_013_PtJakart/lib_protocol/storage_functors.ml index 3c4d9bd4c3643..c9eaa41fa7825 100644 --- a/src/proto_013_PtJakart/lib_protocol/storage_functors.ml +++ b/src/proto_013_PtJakart/lib_protocol/storage_functors.ml @@ -115,7 +115,6 @@ module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : let config t = C.config t module Tree = C.Tree - module Proof = C.Proof let verify_tree_proof = C.verify_tree_proof @@ -247,7 +246,9 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc -> match C.Tree.kind tree with | `Value -> ( - match I.of_path file with None -> assert false | Some p -> f p acc) + match I.of_path file with + | None -> Lwt.return acc + | Some p -> f p acc) | `Tree -> Lwt.return acc) let elements s = @@ -319,7 +320,7 @@ struct C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> ( let key () = C.absolute_key s file in match of_bytes ~key v with @@ -495,7 +496,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL else (* Nominal case *) match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some key -> get_unprojected s key >|=? fun (s, value) -> (s, value :: rev_values, 0, pred length)) @@ -518,9 +519,9 @@ module Make_indexed_carbonated_data_storage_INTERNAL | last :: rest when Compare.String.(last = data_name) -> ( let file = List.rev rest in match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) - | _ -> assert false) + | _ -> Lwt.return acc) | `Tree -> Lwt.return acc) let keys_unaccounted s = @@ -640,7 +641,7 @@ module Make_indexed_data_snapshotable_storage C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> return acc | Some path -> ( let key () = C.absolute_key s file in match V_encoder.of_bytes ~key v with @@ -672,7 +673,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : match C.Tree.kind tree with | `Tree -> ( match I.of_path path with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) | `Value -> Lwt.return acc) @@ -793,8 +794,6 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : C.Tree.empty t end - module Proof = C.Proof - let verify_tree_proof = C.verify_tree_proof let verify_stream_proof = C.verify_stream_proof diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_interpretation.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_interpretation.ml index 2736fa2f42acc..027f83b15edde 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_interpretation.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/michelson/test_interpretation.ml @@ -56,9 +56,9 @@ let logger = let run_step ctxt code accu stack = let open Script_interpreter in let open Contract_helpers in - step None ctxt default_step_constants code accu stack + test_step None ctxt default_step_constants code accu stack >>=? fun ((_, _, ctxt') as r) -> - step (Some logger) ctxt default_step_constants code accu stack + test_step (Some logger) ctxt default_step_constants code accu stack >>=? fun (_, _, ctxt'') -> if Gas.(remaining_operation_gas ctxt' <> remaining_operation_gas ctxt'') then Alcotest.failf "Logging should not have an impact on gas consumption." ; diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml index 70451a0a48926..1f1310aeba9fc 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -124,7 +124,8 @@ let test_multiple_origination_and_delegation () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets |> List.rev @@ -193,7 +194,8 @@ let test_failing_operation_in_the_middle () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets in @@ -241,7 +243,8 @@ let test_failing_operation_in_the_middle_with_fees () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets in diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml index f220b980e85c3..caea833c74c46 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -2815,7 +2815,7 @@ module Rejection = struct Tx_rollup_message_result_hash.hash_uncarbonated previous_message_result; expected = - `Hash + Hash (Tx_rollup_message_result_hash.of_b58check_exn "txmr344vtdPzvWsfnoSd3mJ3MCFA5ehKLQs1pK9WGcX4FEACg1rVgC"); })) @@ -4248,7 +4248,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4269,7 +4269,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4311,7 +4311,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4332,7 +4332,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4610,7 +4610,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = valid_message_index) | _ -> false) incr @@ -4631,7 +4631,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = wrong_message_index) | _ -> false) incr @@ -4654,7 +4654,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = wrong_message_index) | _ -> false) incr diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml index c2e12cad1d39e..69386c9e4478c 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/test_frozen_bonds.ml @@ -76,19 +76,26 @@ let init_test ~user_is_delegate = create_context () >>=? fun (ctxt, _) -> let delegate, delegate_pk, _ = Signature.generate_key () in let delegate_contract = Contract.implicit_contract delegate in - let delegate_account = `Contract (Contract.implicit_contract delegate) in + let delegate_account = + Token.Sink_container (Contract (Contract.implicit_contract delegate)) + in let user_contract = if user_is_delegate then delegate_contract else let user, _, _ = Signature.generate_key () in Contract.implicit_contract user in - let user_account = `Contract user_contract in + let user_account = Token.Contract user_contract in (* Allocate contracts for user and delegate. *) let user_balance = big_random_amount () in - Token.transfer ctxt `Minted user_account user_balance >>>=? fun (ctxt, _) -> + Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container user_account) + user_balance + >>>=? fun (ctxt, _) -> let delegate_balance = big_random_amount () in - Token.transfer ctxt `Minted delegate_account delegate_balance + Token.transfer ctxt (Source_infinite Minted) delegate_account delegate_balance >>>=? fun (ctxt, _) -> (* Configure delegate, as a delegate by self-delegation, for which revealing its manager key is a prerequisite. *) @@ -118,8 +125,12 @@ let test_delegate_then_freeze_deposit () = let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after freeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> @@ -136,7 +147,11 @@ let test_delegate_then_freeze_deposit () = (staking_balance' -! user_balance) >>=? fun () -> (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance of delegate. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance''' -> @@ -166,8 +181,12 @@ let test_freeze_deposit_then_delegate () = let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Here, user balance has decreased. Now, fetch staking balance before delegation and after freeze. *) @@ -183,7 +202,11 @@ let test_freeze_deposit_then_delegate () = (user_balance +! staking_balance) >>=? fun () -> (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after unfreeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance'' -> @@ -220,8 +243,12 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = let tx_rollup, _ = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = user_balance in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that user contract is still allocated, despite a null balance. *) Token.balance ctxt user_account >>>=? fun (ctxt, balance) -> @@ -231,7 +258,11 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = Assert.equal_bool ~loc:__LOC__ (user_allocated && dep_allocated) true >>=? fun () -> (* Punish the user contract. *) - Token.transfer ctxt deposit_account `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that user and deposit accounts have been unallocated. *) Token.allocated ctxt user_account >>>=? fun (ctxt, user_allocated) -> @@ -259,11 +290,19 @@ let test_total_stake ~user_is_delegate () = let tx_rollup, _ = mk_tx_rollup ~nonce () in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in - Token.transfer ctxt user_account deposit_account1 deposit_amount + let deposit_account1 = Token.Frozen_bonds (user_contract, bond_id1) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account1) + deposit_amount >>>=? fun (ctxt, _) -> - let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in - Token.transfer ctxt user_account deposit_account2 deposit_amount + let deposit_account2 = Token.Frozen_bonds (user_contract, bond_id2) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account2) + deposit_amount >>>=? fun (ctxt, _) -> (* Test folding on bond ids. *) Bond_id.Internal_for_tests.fold_on_bond_ids @@ -289,7 +328,11 @@ let test_total_stake ~user_is_delegate () = Assert.equal_tez ~loc:__LOC__ (stake -! balance) (deposit_amount *! 2L) >>=? fun () -> (* Punish for one deposit. *) - Token.transfer ctxt deposit_account2 `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account2) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that stake of contract is balance + deposit. *) Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> @@ -297,7 +340,11 @@ let test_total_stake ~user_is_delegate () = Assert.equal_tez ~loc:__LOC__ (stake -! balance) frozen_bonds >>=? fun () -> Assert.equal_tez ~loc:__LOC__ (stake -! balance) deposit_amount >>=? fun () -> (* Punish for the other deposit. *) - Token.transfer ctxt deposit_account1 `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account1) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that stake of contract is equal to balance. *) Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> diff --git a/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml b/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml index 6f33e53d558bb..74376df719a48 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/integration/test_token.ml @@ -60,11 +60,12 @@ let mk_rollup () = Tx_rollup.Internal_for_tests.originated_tx_rollup nonce let test_simple_balances () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let src = `Contract (Contract.implicit_contract pkh) in + let src = Token.Contract (Contract.implicit_contract pkh) in let pkh, _pk, _sk = Signature.generate_key () in - let dest = `Contract (Contract.implicit_contract pkh) in + let dest = Token.Contract (Contract.implicit_contract pkh) in let amount = Tez.one in - wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> + wrap (Token.transfer ctxt (Source_container src) (Sink_container dest) amount) + >>=? fun (ctxt', _) -> wrap (Token.balance ctxt src) >>=? fun (ctxt, bal_src) -> wrap (Token.balance ctxt' src) >>=? fun (ctxt', bal_src') -> wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> @@ -83,7 +84,12 @@ let test_simple_balance_updates () = let pkh, _pk, _sk = Signature.generate_key () in let dest = Contract.implicit_contract pkh in let amount = Tez.one in - wrap (Token.transfer ctxt (`Contract src) (`Contract dest) amount) + wrap + (Token.transfer + ctxt + (Source_container (Contract src)) + (Sink_container (Contract dest)) + amount) >>=? fun (_, bal_updates) -> Alcotest.( check @@ -109,11 +115,19 @@ let test_allocated_and_deallocated ctxt dest initial_status status_when_empty = wrap (Token.allocated ctxt dest) >>=? fun (ctxt, allocated) -> Assert.equal_bool ~loc:__LOC__ allocated initial_status >>=? fun () -> let amount = Tez.one in - wrap (Token.transfer ctxt `Minted dest amount) >>=? fun (ctxt', _) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container dest) amount) + >>=? fun (ctxt', _) -> wrap (Token.allocated ctxt' dest) >>=? fun (ctxt', allocated) -> Assert.equal_bool ~loc:__LOC__ allocated true >>=? fun () -> wrap (Token.balance ctxt' dest) >>=? fun (ctxt', bal_dest') -> - wrap (Token.transfer ctxt' dest `Burned bal_dest') >>=? fun (ctxt', _) -> + wrap + (Token.transfer + ctxt' + (Source_container dest) + (Sink_infinite Burned) + bal_dest') + >>=? fun (ctxt', _) -> wrap (Token.allocated ctxt' dest) >>=? fun (_, allocated) -> Assert.equal_bool ~loc:__LOC__ allocated status_when_empty >>=? fun () -> return_unit @@ -127,20 +141,20 @@ let test_allocated_and_still_allocated_when_empty ctxt dest initial_status = let test_allocated () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let dest = `Delegate_balance pkh in + let dest = Token.Delegate_balance pkh in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let pkh, _pk, _sk = Signature.generate_key () in - let dest = `Contract (Contract.implicit_contract pkh) in + let dest = Token.Contract (Contract.implicit_contract pkh) in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> - let dest = `Collected_commitments Blinded_public_key_hash.zero in + let dest = Token.Collected_commitments Blinded_public_key_hash.zero in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> - let dest = `Frozen_deposits pkh in + let dest = Token.Frozen_deposits pkh in test_allocated_and_still_allocated_when_empty ctxt dest false >>=? fun _ -> - let dest = `Block_fees in + let dest = Token.Block_fees in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let dest = let bond_id = Bond_id.Tx_rollup_bond_id (mk_rollup ()) in - `Frozen_bonds (Contract.implicit_contract pkh, bond_id) + Token.Frozen_bonds (Contract.implicit_contract pkh, bond_id) in test_allocated_and_deallocated_when_empty ctxt dest @@ -155,20 +169,31 @@ let check_sink_balances ctxt ctxt' dest amount = (`Contract pkh) instead. *) let force_allocation_if_need_be ctxt account = match account with - | `Delegate_balance pkh -> - let account = `Contract (Contract.implicit_contract pkh) in - wrap (Token.transfer ctxt `Minted account Tez.one_mutez) >|=? fst + | Token.Delegate_balance pkh -> + let account = + Token.Sink_container (Contract (Contract.implicit_contract pkh)) + in + wrap (Token.transfer ctxt (Source_infinite Minted) account Tez.one_mutez) + >|=? fst | _ -> return ctxt let test_transferring_to_sink ctxt sink amount expected_bupds = (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt `Minted sink Tez.zero) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container sink) + Tez.zero) + >>=? fun (ctxt', bupds) -> Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true >>=? fun _ -> (* Force the allocation of [dest] if need be. *) force_allocation_if_need_be ctxt sink >>=? fun ctxt -> (* Test transferring a non null amount. *) - wrap (Token.transfer ctxt `Minted sink amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container sink) amount) + >>=? fun (ctxt', bupds) -> check_sink_balances ctxt ctxt' sink amount >>=? fun _ -> let expected_bupds = Receipt.(Minted, Debited amount, Block_application) :: expected_bupds @@ -178,7 +203,9 @@ let test_transferring_to_sink ctxt sink amount expected_bupds = (* Test transferring to go beyond capacity. *) wrap (Token.balance ctxt' sink) >>=? fun (ctxt', bal) -> let amount = Tez.of_mutez_exn Int64.max_int -! bal +! Tez.one_mutez in - wrap (Token.transfer ctxt' `Minted sink amount) >>= fun res -> + wrap + (Token.transfer ctxt' (Source_infinite Minted) (Sink_container sink) amount) + >>= fun res -> Assert.proto_error_with_info ~loc:__LOC__ res "Overflowing tez addition" let test_transferring_to_contract ctxt = @@ -187,7 +214,7 @@ let test_transferring_to_contract ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Contract dest) + (Contract dest) amount [(Contract dest, Credited amount, Block_application)] @@ -196,7 +223,7 @@ let test_transferring_to_collected_commitments ctxt = let bpkh = Blinded_public_key_hash.zero in test_transferring_to_sink ctxt - (`Collected_commitments bpkh) + (Collected_commitments bpkh) amount [(Commitments bpkh, Credited amount, Block_application)] @@ -206,7 +233,7 @@ let test_transferring_to_delegate_balance ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Delegate_balance pkh) + (Delegate_balance pkh) amount [(Contract dest, Credited amount, Block_application)] @@ -215,7 +242,7 @@ let test_transferring_to_frozen_deposits ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Frozen_deposits pkh) + (Frozen_deposits pkh) amount [(Deposits pkh, Credited amount, Block_application)] @@ -223,26 +250,39 @@ let test_transferring_to_collected_fees ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - `Block_fees + Block_fees amount [(Block_fees, Credited amount, Block_application)] let test_transferring_to_burned ctxt = let amount = random_amount () in let minted_bupd = Receipt.(Minted, Debited amount, Block_application) in - wrap (Token.transfer ctxt `Minted `Burned amount) >>=? fun (_, bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_infinite Burned) amount) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = [minted_bupd; (Burned, Credited amount, Block_application)]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Storage_fees amount) >>=? fun (_, bupds) -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Storage_fees) + amount) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = [minted_bupd; (Storage_fees, Credited amount, Block_application)]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Double_signing_punishments amount) + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Double_signing_punishments) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -256,7 +296,11 @@ let test_transferring_to_burned ctxt = let pkh = Signature.Public_key_hash.zero in let p, r = (Random.bool (), Random.bool ()) in wrap - (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount) + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite (Lost_endorsing_rewards (pkh, p, r))) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -275,7 +319,7 @@ let test_transferring_to_frozen_bonds ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Frozen_bonds (contract, bond_id)) + (Frozen_bonds (contract, bond_id)) amount [(Frozen_bonds (contract, bond_id), Credited amount, Block_application)] @@ -298,11 +342,13 @@ let check_src_balances ctxt ctxt' src amount = let test_transferring_from_unbounded_source ctxt src expected_bupds = (* Transferring zero must not return balance updates. *) - wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (_, bupds) -> + wrap (Token.transfer ctxt src (Sink_infinite Burned) Tez.zero) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = []) true >>=? fun () -> (* Test transferring a non null amount. *) let amount = random_amount () in - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (_, bupds) -> + wrap (Token.transfer ctxt src (Sink_infinite Burned) amount) + >>=? fun (_, bupds) -> let expected_bupds = expected_bupds amount @ Receipt.[(Burned, Credited amount, Block_application)] @@ -321,48 +367,76 @@ let test_transferring_from_bounded_source ctxt src amount expected_bupds = balance_no_fail ctxt src >>=? fun (ctxt, balance) -> Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () -> (* Test transferring from an empty account. *) - wrap (Token.transfer ctxt src `Burned Tez.one) >>= fun res -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.one) + >>= fun res -> let error_title = match src with - | `Contract _ -> "Balance too low" - | `Delegate_balance _ | `Frozen_deposits _ | `Frozen_bonds _ -> + | Contract _ -> "Balance too low" + | Delegate_balance _ | Frozen_deposits _ | Frozen_bonds _ -> "Storage error (fatal internal error)" | _ -> "Underflowing tez subtraction" in Assert.proto_error_with_info ~loc:__LOC__ res error_title >>=? fun () -> (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.zero) + >>=? fun (ctxt', bupds) -> Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true >>=? fun _ -> (* Force the allocation of [dest] if need be. *) force_allocation_if_need_be ctxt src >>=? fun ctxt -> (* Test transferring everything. *) - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount) + >>=? fun (ctxt, _) -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) amount) + >>=? fun (ctxt', bupds) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> let expected_bupds = expected_bupds @ Receipt.[(Burned, Credited amount, Block_application)] in Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true >>=? fun () -> (* Test transferring a smaller amount. *) - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount) + >>=? fun (ctxt, _) -> (match src with - | `Frozen_bonds _ -> - wrap (Token.transfer ctxt src `Burned amount) >>= fun res -> + | Frozen_bonds _ -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + amount) + >>= fun res -> let error_title = "Partial spending of frozen bonds" in Assert.proto_error_with_info ~loc:__LOC__ res error_title | _ -> - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + amount) + >>=? fun (ctxt', bupds) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true) >>=? fun () -> (* Test transferring more than available. *) wrap (Token.balance ctxt src) >>=? fun (ctxt, balance) -> - wrap (Token.transfer ctxt src `Burned (balance +! Tez.one)) >>= fun res -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + (balance +! Tez.one)) + >>= fun res -> let error_title = match src with - | `Contract _ -> "Balance too low" - | `Frozen_bonds _ -> "Partial spending of frozen bonds" + | Contract _ -> "Balance too low" + | Frozen_bonds _ -> "Partial spending of frozen bonds" | _ -> "Underflowing tez subtraction" in Assert.proto_error_with_info ~loc:__LOC__ res error_title @@ -373,7 +447,7 @@ let test_transferring_from_contract ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Contract src) + (Contract src) amount [(Contract src, Debited amount, Block_application)] @@ -382,7 +456,7 @@ let test_transferring_from_collected_commitments ctxt = let bpkh = Blinded_public_key_hash.zero in test_transferring_from_bounded_source ctxt - (`Collected_commitments bpkh) + (Collected_commitments bpkh) amount [(Commitments bpkh, Debited amount, Block_application)] @@ -392,7 +466,7 @@ let test_transferring_from_delegate_balance ctxt = let src = Contract.implicit_contract pkh in test_transferring_from_bounded_source ctxt - (`Delegate_balance pkh) + (Delegate_balance pkh) amount [(Contract src, Debited amount, Block_application)] @@ -401,7 +475,7 @@ let test_transferring_from_frozen_deposits ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Frozen_deposits pkh) + (Frozen_deposits pkh) amount [(Deposits pkh, Debited amount, Block_application)] @@ -409,7 +483,7 @@ let test_transferring_from_collected_fees ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - `Block_fees + Block_fees amount [(Block_fees, Debited amount, Block_application)] @@ -421,46 +495,62 @@ let test_transferring_from_frozen_bonds ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Frozen_bonds (contract, bond_id)) + (Frozen_bonds (contract, bond_id)) amount [(Frozen_bonds (contract, bond_id), Debited amount, Block_application)] let test_transferring_from_source () = Random.init 0 ; create_context () >>=? fun (ctxt, _) -> - test_transferring_from_unbounded_source ctxt `Invoice (fun am -> - [(Invoice, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Invoice) + (fun am -> [(Invoice, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Bootstrap (fun am -> - [(Bootstrap, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Bootstrap) + (fun am -> [(Bootstrap, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Initial_commitments (fun am -> - [(Initial_commitments, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Initial_commitments) + (fun am -> [(Initial_commitments, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Revelation_rewards (fun am -> - [(Nonce_revelation_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Revelation_rewards) + (fun am -> [(Nonce_revelation_rewards, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_unbounded_source ctxt - `Double_signing_evidence_rewards + (Source_infinite Double_signing_evidence_rewards) (fun am -> [(Double_signing_evidence_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Endorsing_rewards (fun am -> - [(Endorsing_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Endorsing_rewards) + (fun am -> [(Endorsing_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Baking_rewards (fun am -> - [(Baking_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Baking_rewards) + (fun am -> [(Baking_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Baking_bonuses (fun am -> - [(Baking_bonuses, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Baking_bonuses) + (fun am -> [(Baking_bonuses, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Minted (fun am -> - [(Minted, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Minted) + (fun am -> [(Minted, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_unbounded_source ctxt - `Liquidity_baking_subsidies + (Source_infinite Liquidity_baking_subsidies) (fun am -> [(Liquidity_baking_subsidies, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_contract ctxt >>=? fun _ -> @@ -484,23 +574,25 @@ let cast_to_container_type x = (** Generates all combinations of constructors. *) let build_test_cases () = create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.implicit_contract pkh) in + let origin = + Token.Source_container (Contract (Contract.implicit_contract pkh)) + in let user1, _, _ = Signature.generate_key () in - let user1c = `Contract (Contract.implicit_contract user1) in + let user1c = Token.Contract (Contract.implicit_contract user1) in let user2, _, _ = Signature.generate_key () in - let user2c = `Contract (Contract.implicit_contract user2) in + let user2c = Token.Contract (Contract.implicit_contract user2) in let baker1, baker1_pk, _ = Signature.generate_key () in - let baker1c = `Contract (Contract.implicit_contract baker1) in + let baker1c = Token.Contract (Contract.implicit_contract baker1) in let baker2, baker2_pk, _ = Signature.generate_key () in - let baker2c = `Contract (Contract.implicit_contract baker2) in + let baker2c = Token.Contract (Contract.implicit_contract baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) - wrap (Token.transfer ctxt origin user1c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container user1c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container user2c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker1c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container baker1c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker2c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container baker2c) (random_amount ())) >>=? fun (ctxt, _) -> (* Configure baker1, and baker2 as delegates by self-delegation, for which revealing their manager key is a prerequisite. *) @@ -521,82 +613,90 @@ let build_test_cases () = let baker2ic = Contract.implicit_contract baker2 in let src_list = [ - (`Invoice, random_amount ()); - (`Bootstrap, random_amount ()); - (`Initial_commitments, random_amount ()); - (`Minted, random_amount ()); - (`Liquidity_baking_subsidies, random_amount ()); - (`Collected_commitments Blinded_public_key_hash.zero, random_amount ()); - (`Delegate_balance baker1, random_amount ()); - (`Delegate_balance baker2, random_amount ()); - (`Block_fees, random_amount ()); - (user1c, random_amount ()); - (user2c, random_amount ()); - (baker1c, random_amount ()); - (baker2c, random_amount ()); - (`Frozen_bonds (user1ic, bond_id1), random_amount ()); - (`Frozen_bonds (baker2ic, bond_id2), random_amount ()); + (Token.Source_infinite Invoice, random_amount ()); + (Source_infinite Bootstrap, random_amount ()); + (Source_infinite Initial_commitments, random_amount ()); + (Source_infinite Minted, random_amount ()); + (Source_infinite Liquidity_baking_subsidies, random_amount ()); + ( Source_container (Collected_commitments Blinded_public_key_hash.zero), + random_amount () ); + (Source_container (Delegate_balance baker1), random_amount ()); + (Source_container (Delegate_balance baker2), random_amount ()); + (Source_container Block_fees, random_amount ()); + (Source_container user1c, random_amount ()); + (Source_container user2c, random_amount ()); + (Source_container baker1c, random_amount ()); + (Source_container baker2c, random_amount ()); + (Source_container (Frozen_bonds (user1ic, bond_id1)), random_amount ()); + (Source_container (Frozen_bonds (baker2ic, bond_id2)), random_amount ()); ] in let dest_list = [ - `Collected_commitments Blinded_public_key_hash.zero; - `Delegate_balance baker1; - `Delegate_balance baker2; - `Block_fees; - user1c; - user2c; - baker1c; - baker2c; - `Frozen_bonds (user1ic, bond_id1); - `Frozen_bonds (baker2ic, bond_id2); - `Burned; + Token.Sink_container (Collected_commitments Blinded_public_key_hash.zero); + Sink_container (Delegate_balance baker1); + Sink_container (Delegate_balance baker2); + Sink_container Block_fees; + Sink_container user1c; + Sink_container user2c; + Sink_container baker1c; + Sink_container baker2c; + Sink_container (Frozen_bonds (user1ic, bond_id1)); + Sink_container (Frozen_bonds (baker2ic, bond_id2)); + Sink_infinite Burned; ] in return (ctxt, List.product src_list dest_list) -let check_src_balances ctxt ctxt' src amount = - match cast_to_container_type src with - | None -> return_unit - | Some src -> check_src_balances ctxt ctxt' src amount - -let check_sink_balances ctxt ctxt' dest amount = - match cast_to_container_type dest with - | None -> return_unit - | Some dest -> check_sink_balances ctxt ctxt' dest amount - let rec check_balances ctxt ctxt' src dest amount = - match (cast_to_container_type src, cast_to_container_type dest) with - | None, None -> return_unit - | Some (`Delegate_balance d), Some (`Contract c as contract) + match (src, dest) with + | ( Token.Source_container (Delegate_balance d), + Token.Sink_container (Contract c as contract) ) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) - check_balances ctxt ctxt' contract contract amount - | Some (`Contract c as contract), Some (`Delegate_balance d) + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | ( Source_container (Contract c as contract), + Sink_container (Delegate_balance d) ) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) - check_balances ctxt ctxt' contract contract amount - | Some src, Some dest when src = dest -> + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | Source_container src, Sink_container dest when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | Some src, None -> check_src_balances ctxt ctxt' src amount - | None, Some dest -> check_sink_balances ctxt ctxt' dest amount - | Some src, Some dest -> + | Source_container src, Sink_container dest -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount + | Source_container src, _ -> check_src_balances ctxt ctxt' src amount + | _, Sink_container dest -> check_sink_balances ctxt ctxt' dest amount + | _, _ -> return_unit let test_all_combinations_of_sources_and_sinks () = Random.init 0 ; build_test_cases () >>=? fun (ctxt, cases) -> List.iter_es (fun ((src, amount), dest) -> - (match cast_to_container_type src with - | None -> return ctxt - | Some src -> - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> - return ctxt) + (match src with + | Token.Source_container src -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container src) + amount) + >>=? fun (ctxt, _) -> return ctxt + | _ -> return ctxt) >>=? fun ctxt -> wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> check_balances ctxt ctxt' src dest amount) @@ -631,15 +731,20 @@ let coalesce_balance_updates bu1 bu2 = (** Check that elt has the same balance in ctxt1 and ctxt2. *) let check_balances_are_consistent ctxt1 ctxt2 elt = - match elt with - | #Token.container as elt -> - Token.balance ctxt1 elt >>=? fun (_, elt_bal1) -> - Token.balance ctxt2 elt >>=? fun (_, elt_bal2) -> - assert (elt_bal1 = elt_bal2) ; - return_unit - | `Invoice | `Bootstrap | `Initial_commitments | `Minted - | `Liquidity_baking_subsidies | `Burned -> - return_unit + Token.balance ctxt1 elt >>=? fun (_, elt_bal1) -> + Token.balance ctxt2 elt >>=? fun (_, elt_bal2) -> + assert (elt_bal1 = elt_bal2) ; + return_unit + +let check_balances_are_consistent_source ctxt1 ctxt2 src = + match src with + | Token.Source_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt + | _ -> return_unit + +let check_balances_are_consistent_dest ctxt1 ctxt2 dest = + match dest with + | Token.Sink_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt + | _ -> return_unit (** Test that [transfer_n] is equivalent to n debits followed by n credits. *) let test_transfer_n ctxt src dest = @@ -648,29 +753,29 @@ let test_transfer_n ctxt src dest = (* Debit all sources. *) List.fold_left_es (fun (ctxt, bal_updates) (src, am) -> - Token.transfer ctxt src `Burned am >>=? fun (ctxt, debit_logs) -> - return (ctxt, bal_updates @ debit_logs)) + Token.transfer ctxt src (Sink_infinite Burned) am + >>=? fun (ctxt, debit_logs) -> return (ctxt, bal_updates @ debit_logs)) (ctxt, []) src >>=? fun (ctxt, debit_logs) -> (* remove burning balance updates *) let debit_logs = List.filter - (fun b -> match b with Receipt.Burned, _, _ -> false | _ -> true) + (fun b -> match b with Receipt.(Burned), _, _ -> false | _ -> true) debit_logs in (* Credit the sink for each source. *) List.fold_left_es (fun (ctxt, bal_updates) (_, am) -> - Token.transfer ctxt `Minted dest am >>=? fun (ctxt, credit_logs) -> - return (ctxt, bal_updates @ credit_logs)) + Token.transfer ctxt (Source_infinite Minted) dest am + >>=? fun (ctxt, credit_logs) -> return (ctxt, bal_updates @ credit_logs)) (ctxt, []) src >>=? fun (ctxt2, credit_logs) -> (* remove minting balance updates *) let credit_logs = List.filter - (fun b -> match b with Receipt.Minted, _, _ -> false | _ -> true) + (fun b -> match b with Receipt.(Minted), _, _ -> false | _ -> true) credit_logs in (* Check equivalence of balance updates. *) @@ -681,46 +786,56 @@ let test_transfer_n ctxt src dest = in assert (bal_updates1 = debit_logs @ credit_logs) ; (* Check balances are the same in ctxt1 and ctxt2. *) - List.(iter_es (check_balances_are_consistent ctxt1 ctxt2) (map fst src)) - >>=? fun _ -> check_balances_are_consistent ctxt1 ctxt2 dest + List.( + iter_es (check_balances_are_consistent_source ctxt1 ctxt2) (map fst src)) + >>=? fun _ -> check_balances_are_consistent_dest ctxt1 ctxt2 dest let test_transfer_n_with_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - wrap (test_transfer_n ctxt [] `Block_fees) >>=? fun _ -> - let dest = `Delegate_balance pkh in + wrap (test_transfer_n ctxt [] (Sink_container Block_fees)) >>=? fun _ -> + let dest = Token.Sink_container (Delegate_balance pkh) in wrap (test_transfer_n ctxt [] dest) let test_transfer_n_with_non_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.implicit_contract pkh) in + let origin = + Token.Source_container (Contract (Contract.implicit_contract pkh)) + in let user1, _, _ = Signature.generate_key () in - let user1c = `Contract (Contract.implicit_contract user1) in + let user1c = Token.Contract (Contract.implicit_contract user1) in let user2, _, _ = Signature.generate_key () in - let user2c = `Contract (Contract.implicit_contract user2) in + let user2c = Token.Contract (Contract.implicit_contract user2) in let user3, _, _ = Signature.generate_key () in - let user3c = `Contract (Contract.implicit_contract user3) in + let user3c = Token.Contract (Contract.implicit_contract user3) in let user4, _, _ = Signature.generate_key () in - let user4c = `Contract (Contract.implicit_contract user4) in + let user4c = Token.Contract (Contract.implicit_contract user4) in (* Allocate contracts for user1, user2, user3, and user4. *) let amount = match Tez.of_mutez 1000L with None -> assert false | Some x -> x in - wrap (Token.transfer ctxt origin user1c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user3c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user4c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container user1c) amount) + >>=? fun (ctxt, _) -> + wrap (Token.transfer ctxt origin (Sink_container user2c) amount) + >>=? fun (ctxt, _) -> + wrap (Token.transfer ctxt origin (Sink_container user3c) amount) + >>=? fun (ctxt, _) -> + wrap (Token.transfer ctxt origin (Sink_container user4c) (random_amount ())) >>=? fun (ctxt, _) -> let sources = [ - (user2c, random_amount ()); - (user3c, random_amount ()); - (user4c, random_amount ()); + (Token.Source_container user2c, random_amount ()); + (Source_container user3c, random_amount ()); + (Source_container user4c, random_amount ()); ] in - wrap (test_transfer_n ctxt sources user1c) >>=? fun _ -> - wrap (test_transfer_n ctxt ((user1c, random_amount ()) :: sources) user1c) + wrap (test_transfer_n ctxt sources (Sink_container user1c)) >>=? fun _ -> + wrap + (test_transfer_n + ctxt + ((Source_container user1c, random_amount ()) :: sources) + (Sink_container user1c)) let tests = Tztest. diff --git a/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml index da13b983e01a8..9bead215412e2 100644 --- a/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml +++ b/src/proto_013_PtJakart/lib_protocol/test/unit/test_tx_rollup_l2.ml @@ -202,8 +202,7 @@ module type S = sig val set_count : t -> int32 -> t m - val get_or_associate_index : - t -> value -> (t * [`Created | `Existed] * index) m + val get_or_associate_index : t -> value -> (t * created_existed * index) m val get : t -> value -> index option m @@ -224,7 +223,7 @@ module Test_index (Index : S) = struct let* ctxt, value = init_context_1 () in let* ctxt, created, idx1 = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; let* idx2 = Index.get ctxt value in assert (Some idx1 = idx2) ; @@ -244,7 +243,7 @@ module Test_index (Index : S) = struct assert (idx = None) ; let* ctxt, created, idx = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; let* count = Index.count ctxt in assert (count = 1l) ; @@ -260,14 +259,14 @@ module Test_index (Index : S) = struct let expected = Indexable.index_exn 0l in let* ctxt, created, idx = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; assert (idx = expected) ; let* idx = Index.get ctxt value in assert (idx = Some (Indexable.index_exn 0l)) ; let* ctxt, existed, idx = Index.get_or_associate_index ctxt value in - assert (existed = `Existed) ; + assert (existed = Existed) ; assert (idx = expected) ; let* count = Index.count ctxt in diff --git a/src/proto_013_PtJakart/lib_protocol/ticket_accounting.ml b/src/proto_013_PtJakart/lib_protocol/ticket_accounting.ml index e04e6c5c19fb0..19edb40736a50 100644 --- a/src/proto_013_PtJakart/lib_protocol/ticket_accounting.ml +++ b/src/proto_013_PtJakart/lib_protocol/ticket_accounting.ml @@ -58,7 +58,7 @@ module Ticket_token_map = struct Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) >|? fun ctxt -> (Z.add b1 b2, ctxt) - let of_list ctxt token_amounts = + let of_list_with_merge ctxt token_amounts = Ticket_token_map.of_list ctxt ~merge_overlap token_amounts let add ctxt = Ticket_token_map.merge ctxt ~merge_overlap @@ -83,9 +83,9 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = >|? fun ctxt -> ((token, Script_int.to_zint amount) :: acc, ctxt)) ([], ctxt) tickets - >>?= fun (list, ctxt) -> Ticket_token_map.of_list ctxt list + >>?= fun (list, ctxt) -> Ticket_token_map.of_list_with_merge ctxt list -let update_ticket_balances ctxt ~total_storage_diff token destinations = +let update_ticket_balances_raw ctxt ~total_storage_diff token destinations = List.fold_left_es (fun (tot_storage_diff, ctxt) (owner, delta) -> Ticket_balance_key.of_ex_token ctxt ~owner token @@ -117,7 +117,7 @@ let update_ticket_balances_for_self_contract ctxt ~self ticket_diffs = is_valid_balance_update (invalid_ticket_transfer_error ~ticket_token ~amount) >>?= fun () -> - update_ticket_balances + update_ticket_balances_raw ctxt ~total_storage_diff ticket_token @@ -132,7 +132,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt lazy_storage_diff - >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list ctxt diffs + >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list_with_merge ctxt diffs else return (Ticket_token_map.empty, ctxt) (* TODO #2465 @@ -242,6 +242,10 @@ let update_ticket_balances ctxt ~self ~ticket_diffs operations = ([], ctxt) destinations >>?= fun (destinations, ctxt) -> - update_ticket_balances ctxt ~total_storage_diff ticket_token destinations) + update_ticket_balances_raw + ctxt + ~total_storage_diff + ticket_token + destinations) (total_storage_diff, ctxt) ticket_op_diffs diff --git a/src/proto_013_PtJakart/lib_protocol/ticket_hash_builder.ml b/src/proto_013_PtJakart/lib_protocol/ticket_hash_builder.ml index fc7f79181e183..1fdc9e9245dc1 100644 --- a/src/proto_013_PtJakart/lib_protocol/ticket_hash_builder.ml +++ b/src/proto_013_PtJakart/lib_protocol/ticket_hash_builder.ml @@ -41,11 +41,11 @@ let () = (fun () -> Failed_to_hash_node) let hash_bytes_cost bytes = - let module S = Saturation_repr in - let ( + ) = S.add in - let v0 = S.safe_int @@ Bytes.length bytes in - let ( lsr ) = S.shift_right in - S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost + let ( + ) = Saturation_repr.add in + let v0 = Saturation_repr.safe_int @@ Bytes.length bytes in + let ( lsr ) = Saturation_repr.shift_right in + Saturation_repr.safe_int 200 + (v0 + (v0 lsr 2)) + |> Gas_limit_repr.atomic_step_cost let hash_of_node ctxt node = Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node) diff --git a/src/proto_013_PtJakart/lib_protocol/ticket_hash_repr.ml b/src/proto_013_PtJakart/lib_protocol/ticket_hash_repr.ml index 21c1869114041..274f6366f3219 100644 --- a/src/proto_013_PtJakart/lib_protocol/ticket_hash_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/ticket_hash_repr.ml @@ -23,16 +23,33 @@ (* *) (*****************************************************************************) -include Script_expr_hash +type t = Script_expr_hash.t -let of_script_expr_hash t = t +let encoding = Script_expr_hash.encoding + +let pp = Script_expr_hash.pp + +let to_b58check = Script_expr_hash.to_b58check + +let of_b58check_opt = Script_expr_hash.of_b58check_opt + +let of_b58check_exn = Script_expr_hash.of_b58check_exn -let zero = zero +let of_bytes_exn = Script_expr_hash.of_bytes_exn + +let of_bytes_opt = Script_expr_hash.of_bytes_opt include Compare.Make (struct - type nonrec t = t + type nonrec t = Script_expr_hash.t - let compare = compare + let compare = Script_expr_hash.compare end) -module Index = Script_expr_hash +let zero = Script_expr_hash.zero + +let of_script_expr_hash t = t + +module Index : Storage_description.INDEX with type t = Script_expr_hash.t = +struct + include Script_expr_hash +end diff --git a/src/proto_013_PtJakart/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_013_PtJakart/lib_protocol/ticket_lazy_storage_diff.ml index eb19db16ab7eb..3b90e7d5163ea 100644 --- a/src/proto_013_PtJakart/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_013_PtJakart/lib_protocol/ticket_lazy_storage_diff.ml @@ -76,7 +76,7 @@ let parse_value_type ctxt value_type = removing a value containing tickets. *) let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc = - Ticket_scanner.tickets_of_node + (Ticket_scanner.tickets_of_node [@coq_implicit "a" "a"]) ctxt (* It's currently not possible to have nested lazy structures, but this is for future proofing. *) @@ -111,7 +111,7 @@ let collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets = match expr_opt with | Some expr -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "a" "a"]) ctxt has_tickets expr @@ -165,12 +165,12 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates We should have the non-serialized version of the value type. *) parse_value_type ctxt value_type - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> List.fold_left_es (fun (acc, already_updated, ctxt) update -> - collect_token_diffs_of_big_map_update + (collect_token_diffs_of_big_map_update [@coq_implicit "a" "__Ex_ty_'a"]) ctxt ~big_map_id has_tickets @@ -195,7 +195,8 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = type. It would be more efficient if the value preserved. *) parse_value_type ctxt value_ty - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) + -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> (* Iterate over big-map items. *) @@ -207,7 +208,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = Big_map.list_values ctxt big_map_id >>=? fun (ctxt, exprs) -> List.fold_left_es (fun (acc, ctxt) node -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "a" "__Ex_ty_'a"]) ctxt has_tickets node @@ -238,15 +239,23 @@ let collect_token_diffs_of_big_map_and_updates ctxt big_map_id updates acc = let collect_token_diffs_of_big_map_diff ctxt diff_item acc = Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step >>?= fun ctxt -> - match diff_item with - | Lazy_storage.Item (Lazy_storage_kind.Big_map, big_map_id, Remove) -> + match[@coq_match_gadt] diff_item with + | Lazy_storage.Item + (Lazy_storage_kind.Big_map, (big_map_id : Big_map.Id.t), Remove) -> (* Collect all removed tokens from the big-map. *) collect_token_diffs_of_big_map ctxt ~get_token_and_amount:neg_token_and_amount big_map_id acc - | Item (Lazy_storage_kind.Big_map, big_map_id, Update {init; updates}) -> ( + | Item + ( Lazy_storage_kind.Big_map, + (big_map_id : Big_map.Id.t), + (Update {init; updates} : + ( Big_map.Id.t, + Lazy_storage_kind.Big_map.alloc, + Lazy_storage_kind.Big_map.updates ) + Lazy_storage.diff) ) -> ( match init with | Lazy_storage.Existing -> (* Collect token diffs from the updates to the big-map. *) diff --git a/src/proto_013_PtJakart/lib_protocol/ticket_operations_diff.ml b/src/proto_013_PtJakart/lib_protocol/ticket_operations_diff.ml index 60837e56e1724..f3c64c590079d 100644 --- a/src/proto_013_PtJakart/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_013_PtJakart/lib_protocol/ticket_operations_diff.ml @@ -166,7 +166,8 @@ let cast_transaction_parameter (type a ac b bc) ctxt location entry_arg_ty parameters_ty) >>?= fun (res, ctxt) -> - res >>?= fun Script_ir_translator.Eq -> return ((parameters : a), ctxt) + res >>?= fun Script_ir_translator.Eq -> + return (((parameters [@coq_cast]) : a), ctxt) let tickets_of_transaction ctxt ~destination ~entrypoint ~location ~parameters_ty ~parameters = @@ -187,19 +188,19 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location match script_opt with | None -> fail (Failed_to_get_script destination) | Some script -> return (script, ctxt)) - >>=? fun ( Script_ir_translator.Ex_script - (Script {arg_type; entrypoints; _}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Script_ir_translator.Ex_script + (Script {arg_type; entrypoints; _}), + ctxt ) -> (* Find the entrypoint type for the given entrypoint. *) - Gas_monad.run - ctxt - (Script_ir_translator.find_entrypoint - ~error_details:Informative - arg_type - entrypoints - entrypoint) + (Gas_monad.run + ctxt + (Script_ir_translator.find_entrypoint + ~error_details:Informative + arg_type + entrypoints + entrypoint) [@coq_type_annotation]) >>?= fun (res, ctxt) -> - res >>?= fun (Ex_ty_cstr {ty = entry_arg_ty; _}) -> + res >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entry_arg_ty; _}) -> Ticket_scanner.type_has_tickets ctxt entry_arg_ty >>?= fun (has_tickets, ctxt) -> (* Check that the parameter's type matches that of the entry-point, and @@ -215,7 +216,7 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location ~include_lazy:true ctxt has_tickets - parameters + (parameters [@coq_type_annotation]) >>=? fun (tickets, ctxt) -> return (Some {destination = Contract destination; tickets}, ctxt) diff --git a/src/proto_013_PtJakart/lib_protocol/ticket_scanner.ml b/src/proto_013_PtJakart/lib_protocol/ticket_scanner.ml index 2956a01816d12..5217fcbb8cc1f 100644 --- a/src/proto_013_PtJakart/lib_protocol/ticket_scanner.ml +++ b/src/proto_013_PtJakart/lib_protocol/ticket_scanner.ml @@ -108,7 +108,7 @@ module Ticket_inspection = struct a Script_typed_ir.comparable_ty -> (a has_tickets -> ret) -> ret = fun key_ty k -> let open Script_typed_ir in - match key_ty with + match[@coq_match_with_default] key_ty with | Unit_t -> (k [@ocaml.tailcall]) False_ht | Never_t -> (k [@ocaml.tailcall]) False_ht | Int_t -> (k [@ocaml.tailcall]) False_ht @@ -143,7 +143,7 @@ module Ticket_inspection = struct The returned value matches the given shape of the [ty] value, except it collapses whole branches where no types embed tickets to [False_ht]. *) - let rec has_tickets_of_ty : + let rec has_tickets_of_ty_aux : type a ac ret. (a, ac) Script_typed_ir.ty -> (a, ret) continuation -> ret tzresult = fun ty k -> @@ -180,11 +180,11 @@ module Ticket_inspection = struct a packable type and tickets are not packable. *) (k [@ocaml.tailcall]) False_ht | Option_t (ty, _, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let opt_hty = map_has_tickets (fun ht -> Option_ht ht) ht in (k [@ocaml.tailcall]) opt_hty) | List_t (ty, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let list_hty = map_has_tickets (fun ht -> List_ht ht) ht in (k [@ocaml.tailcall]) list_hty) | Set_t (key_ty, _) -> @@ -219,7 +219,7 @@ module Ticket_inspection = struct | Chest_t -> (k [@ocaml.tailcall]) False_ht | Chest_key_t -> (k [@ocaml.tailcall]) False_ht - and has_tickets_of_pair : + and[@coq_mutual_as_notation] has_tickets_of_pair : type a ac b bc c ret. (a, ac) Script_typed_ir.ty -> (b, bc) Script_typed_ir.ty -> @@ -227,11 +227,11 @@ module Ticket_inspection = struct (c, ret) continuation -> ret tzresult = fun ty1 ty2 ~pair k -> - (has_tickets_of_ty [@ocaml.tailcall]) ty1 (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) ty2 (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty1 (fun ht1 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty2 (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) - and has_tickets_of_key_and_value : + and[@coq_mutual_as_notation] has_tickets_of_key_and_value : type k v vc t ret. k Script_typed_ir.comparable_ty -> (v, vc) Script_typed_ir.ty -> @@ -240,12 +240,12 @@ module Ticket_inspection = struct ret tzresult = fun key_ty val_ty ~pair k -> (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) val_ty (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) val_ty (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) let has_tickets_of_ty ctxt ty = Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) >>? fun ctxt -> - has_tickets_of_ty ty ok >|? fun ht -> (ht, ctxt) + has_tickets_of_ty_aux ty ok >|? fun ht -> (ht, ctxt) end module Ticket_collection = struct @@ -273,7 +273,7 @@ module Ticket_collection = struct ret tzresult Lwt.t = fun ctxt comp_ty acc k -> let open Script_typed_ir in - match comp_ty with + match[@coq_match_with_default] comp_ty with | Unit_t -> (k [@ocaml.tailcall]) ctxt acc | Never_t -> (k [@ocaml.tailcall]) ctxt acc | Int_t -> (k [@ocaml.tailcall]) ctxt acc @@ -307,7 +307,7 @@ module Ticket_collection = struct comparable. *) (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc k - let rec tickets_of_value : + let[@coq_struct "hty"] rec tickets_of_value_aux : type a ac ret. include_lazy:bool -> Alpha_context.context -> @@ -320,11 +320,13 @@ module Ticket_collection = struct fun ~include_lazy ctxt hty ty x acc k -> let open Script_typed_ir in consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> - match (hty, ty) with - | (False_ht, _) -> (k [@ocaml.tailcall]) ctxt acc - | (Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _)) -> + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (hty, ty, x) + with + | (False_ht, _, _) -> (k [@ocaml.tailcall]) ctxt acc + | (Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _), (x : _ * _)) -> let (l, r) = x in - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt hty1 @@ -332,7 +334,7 @@ module Ticket_collection = struct l acc (fun ctxt acc -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt hty2 @@ -340,10 +342,10 @@ module Ticket_collection = struct r acc k) - | (Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _)) -> ( - match x with + | (Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _), (x : _ union)) -> ( + match[@coq_match_gadt_with_result] x with | L v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt htyl @@ -352,7 +354,7 @@ module Ticket_collection = struct acc k | R v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt htyr @@ -360,10 +362,10 @@ module Ticket_collection = struct v acc k) - | (Option_ht el_hty, Option_t (el_ty, _, _)) -> ( - match x with + | (Option_ht el_hty, Option_t (el_ty, _, _), (x : _ option)) -> ( + match[@coq_match_gadt_with_result] x with | Some x -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt el_hty @@ -372,7 +374,7 @@ module Ticket_collection = struct acc k | None -> (k [@ocaml.tailcall]) ctxt acc) - | (List_ht el_hty, List_t (el_ty, _)) -> + | (List_ht el_hty, List_t (el_ty, _), (x : _ Script_typed_ir.boxed_list)) -> let {elements; _} = x in (tickets_of_list [@ocaml.tailcall]) ctxt @@ -382,9 +384,11 @@ module Ticket_collection = struct elements acc k - | (Set_ht _, Set_t (key_ty, _)) -> + | (Set_ht _, Set_t (key_ty, _), (x : _ set)) -> (tickets_of_set [@ocaml.tailcall]) ctxt key_ty x acc k - | (Map_ht (_, val_hty), Map_t (key_ty, val_ty, _)) -> + | ( Map_ht (_, val_hty), + Map_t (key_ty, val_ty, _), + (x : (_, _) Script_typed_ir.map) ) -> (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty @@ -398,14 +402,16 @@ module Ticket_collection = struct x acc k) - | (Big_map_ht (_, val_hty), Big_map_t (key_ty, _, _)) -> + | ( Big_map_ht (_, val_hty), + Big_map_t (key_ty, _, _), + (x : (_, _) Script_typed_ir.big_map) ) -> if include_lazy then (tickets_of_big_map [@ocaml.tailcall]) ctxt val_hty key_ty x acc k else (k [@ocaml.tailcall]) ctxt acc - | (True_ht, Ticket_t (comp_ty, _)) -> + | (True_ht, Ticket_t (comp_ty, _), (x : _ ticket)) -> (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) - and tickets_of_list : + and[@coq_struct "elements"] tickets_of_list : type a ac ret. Alpha_context.context -> include_lazy:bool -> @@ -419,7 +425,7 @@ module Ticket_collection = struct consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> match elements with | elem :: elems -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt el_hty @@ -437,7 +443,7 @@ module Ticket_collection = struct k) | [] -> (k [@ocaml.tailcall]) ctxt acc - and tickets_of_map : + and[@coq_struct "map"] tickets_of_map : type k v vc ret. include_lazy:bool -> Alpha_context.context -> @@ -462,7 +468,7 @@ module Ticket_collection = struct acc k - and tickets_of_big_map : + and[@coq_struct "function_parameter"] tickets_of_big_map : type k v ret. Alpha_context.context -> v Ticket_inspection.has_tickets -> @@ -509,7 +515,7 @@ module Ticket_collection = struct | None -> (k [@ocaml.tailcall]) ctxt acc) let tickets_of_value ctxt ~include_lazy ht ty x = - tickets_of_value ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> + tickets_of_value_aux ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> return (ex_tickets, ctxt)) end @@ -517,6 +523,7 @@ type 'a has_tickets = | Has_tickets : 'a Ticket_inspection.has_tickets * ('a, _) Script_typed_ir.ty -> 'a has_tickets +[@@coq_force_gadt] let type_has_tickets ctxt ty = Ticket_inspection.has_tickets_of_ty ctxt ty >|? fun (has_tickets, ctxt) -> @@ -532,8 +539,8 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr = let (Has_tickets (ht, ty)) = has_tickets in match ht with | Ticket_inspection.False_ht -> return ([], ctxt) - | _ -> - Script_ir_translator.parse_data + | (_ : _ Ticket_inspection.has_tickets) -> + (Script_ir_translator.parse_data [@coq_implicit "A" "a"]) ctxt ~legacy:true ~allow_forged:true diff --git a/src/proto_013_PtJakart/lib_protocol/ticket_scanner.mli b/src/proto_013_PtJakart/lib_protocol/ticket_scanner.mli index 209c633ab74ab..c732b79842a88 100644 --- a/src/proto_013_PtJakart/lib_protocol/ticket_scanner.mli +++ b/src/proto_013_PtJakart/lib_protocol/ticket_scanner.mli @@ -39,7 +39,7 @@ type ex_ticket = (** A type-witness that contains information about which branches of a type ['a] include tickets. This value is used for traversing only the relevant branches of values when scanning for tickets. *) -type 'a has_tickets +type 'a has_tickets [@@coq_phantom] (** [type_has_tickets ctxt ty] returns a [has_tickets] witness of the given shape [ty]. diff --git a/src/proto_013_PtJakart/lib_protocol/token.ml b/src/proto_013_PtJakart/lib_protocol/token.ml index 67f1083a0039d..a25df17641010 100644 --- a/src/proto_013_PtJakart/lib_protocol/token.ml +++ b/src/proto_013_PtJakart/lib_protocol/token.ml @@ -24,70 +24,72 @@ (*****************************************************************************) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Burned + | Tx_rollup_rejection_punishments -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container let allocated ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.allocated ctxt contract >|=? fun allocated -> (ctxt, allocated) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.exists ctxt bpkh >|= ok >|=? fun allocated -> (ctxt, allocated) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Contract_storage.allocated ctxt contract >|=? fun allocated -> (ctxt, allocated) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.implicit_contract delegate in Frozen_deposits_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Block_fees -> return (ctxt, true) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, true) + | Frozen_bonds (contract, bond_id) -> Contract_storage.bond_allocated ctxt contract bond_id let balance ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.get_balance ctxt contract >|=? fun balance -> (ctxt, balance) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.committed_amount ctxt bpkh >|=? fun balance -> (ctxt, balance) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Storage.Contract.Spendable_balance.get ctxt contract >|=? fun balance -> (ctxt, balance) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.implicit_contract delegate in Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits -> let balance = @@ -96,44 +98,44 @@ let balance ctxt stored = | Some frozen_deposits -> frozen_deposits.current_amount in (ctxt, balance) - | `Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) + | Frozen_bonds (contract, bond_id) -> Contract_storage.find_bond ctxt contract bond_id >|=? fun (ctxt, balance_opt) -> (ctxt, Option.value ~default:Tez_repr.zero balance_opt) -let credit ctxt dest amount origin = +let credit ctxt (dest : sink) amount origin = let open Receipt_repr in (match dest with - | #infinite_sink as infinite_sink -> + | Sink_infinite infinite_sink -> let sink = match infinite_sink with - | `Storage_fees -> Storage_fees - | `Double_signing_punishments -> Double_signing_punishments - | `Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) - | `Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments - | `Burned -> Burned + | Storage_fees -> Storage_fees + | Double_signing_punishments -> Double_signing_punishments + | Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) + | Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments + | Burned -> Burned in return (ctxt, sink) - | #container as container -> ( + | Sink_container container -> ( match container with - | `Contract dest -> + | Contract dest -> Contract_storage.credit_only_call_from_token ctxt dest amount >|=? fun ctxt -> (ctxt, Contract dest) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.increase_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Contract_storage.increase_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate as dest -> + | Frozen_deposits delegate as dest -> allocated ctxt dest >>=? fun (ctxt, allocated) -> (if not allocated then Frozen_deposits_storage.init ctxt delegate else return ctxt) @@ -143,10 +145,10 @@ let credit ctxt dest amount origin = delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.credit_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.credit_bond_only_call_from_token ctxt contract @@ -155,53 +157,53 @@ let credit ctxt dest amount origin = >>=? fun ctxt -> return (ctxt, Frozen_bonds (contract, bond_id)))) >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin)) -let spend ctxt src amount origin = +let spend ctxt (src : source) amount origin = let open Receipt_repr in (match src with - | #infinite_source as infinite_source -> + | Source_infinite infinite_source -> let src = match infinite_source with - | `Bootstrap -> Bootstrap - | `Invoice -> Invoice - | `Initial_commitments -> Initial_commitments - | `Minted -> Minted - | `Liquidity_baking_subsidies -> Liquidity_baking_subsidies - | `Revelation_rewards -> Nonce_revelation_rewards - | `Double_signing_evidence_rewards -> Double_signing_evidence_rewards - | `Endorsing_rewards -> Endorsing_rewards - | `Baking_rewards -> Baking_rewards - | `Baking_bonuses -> Baking_bonuses - | `Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards + | Bootstrap -> Bootstrap + | Invoice -> Invoice + | Initial_commitments -> Initial_commitments + | Minted -> Minted + | Liquidity_baking_subsidies -> Liquidity_baking_subsidies + | Revelation_rewards -> Nonce_revelation_rewards + | Double_signing_evidence_rewards -> Double_signing_evidence_rewards + | Endorsing_rewards -> Endorsing_rewards + | Baking_rewards -> Baking_rewards + | Baking_bonuses -> Baking_bonuses + | Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards in return (ctxt, src) - | #container as container -> ( + | Source_container container -> ( match container with - | `Contract src -> + | Contract src -> Contract_storage.spend_only_call_from_token ctxt src amount >|=? fun ctxt -> (ctxt, Contract src) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.decrease_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Contract_storage.decrease_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> Frozen_deposits_storage.spend_only_call_from_token ctxt delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.spend_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.spend_bond_only_call_from_token ctxt contract @@ -234,9 +236,10 @@ let transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest = List.fold_left_es (fun ctxt (source, _amount) -> match source with - | `Contract contract | `Frozen_bonds (contract, _) -> + | Source_container (Contract contract) + | Source_container (Frozen_bonds (contract, _)) -> Contract_storage.ensure_deallocated_if_empty ctxt contract - | #source -> return ctxt) + | _ -> return ctxt) ctxt sources >|=? fun ctxt -> diff --git a/src/proto_013_PtJakart/lib_protocol/token.mli b/src/proto_013_PtJakart/lib_protocol/token.mli index 2fe5f2cb84469..fcbc3b0e396f4 100644 --- a/src/proto_013_PtJakart/lib_protocol/token.mli +++ b/src/proto_013_PtJakart/lib_protocol/token.mli @@ -43,42 +43,44 @@ stake. *) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t (** [infinite_source] defines types of tokens provides which are considered to be ** of infinite capacity. *) type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards (** [source] is the type of token providers. Token providers that are not containers are considered to have infinite capacity. *) -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Burned + | Tx_rollup_rejection_punishments (** [sink] is the type of token receivers. Token receivers that are not containers are considered to have infinite capacity. *) -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container (** [allocated ctxt container] returns a new context because of possible access to carbonated data, and a boolean that is [true] when @@ -109,8 +111,8 @@ val balance : val transfer_n : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - ([< source] * Tez_repr.t) list -> - [< sink] -> + (source * Tez_repr.t) list -> + sink -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t (** [transfer ?origin ctxt src dest amount] transfers [amount] Tez from source @@ -137,7 +139,7 @@ val transfer_n : val transfer : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - [< source] -> - [< sink] -> + source -> + sink -> Tez_repr.t -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.ml index 6de7e88e16950..3d8da9c0aaed5 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.ml @@ -94,7 +94,13 @@ type 'a template = { inbox_merkle_root : Tx_rollup_inbox_repr.Merkle.root; } -let map_template f x = {x with messages = f x.messages} +let map_template f x = + { + level = x.level; + messages = f x.messages; + predecessor = x.predecessor; + inbox_merkle_root = x.inbox_merkle_root; + } let pp_template : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a template -> unit diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.mli b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.mli index 8a396f24d3986..277059cb20e75 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.mli +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_repr.mli @@ -33,7 +33,7 @@ module Hash : sig include S.HASH end -module Merkle_hash : S.HASH +module Merkle_hash : S.HASH [@@coq_plain_module] module Merkle : Merkle_list.T diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.ml index 641b33cb61bb2..bb0e2e45bb4a1 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.ml @@ -50,10 +50,14 @@ open Tx_rollup_errors_repr *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + let check_message_result ctxt {messages; _} result ~path ~index = (match result with - | `Hash hash -> ok (ctxt, hash) - | `Result result -> Tx_rollup_hash_builder.message_result ctxt result) + | Hash hash -> ok (ctxt, hash) + | Result result -> Tx_rollup_hash_builder.message_result ctxt result) >>? fun (ctxt, computed) -> Tx_rollup_gas.consume_check_path_commitment_cost ctxt >>? fun ctxt -> let cond = @@ -71,11 +75,13 @@ let check_message_result ctxt {messages; _} result ~path ~index = cond Tx_rollup_errors_repr.( Wrong_rejection_hash - {provided = computed; expected = `Valid_path (messages.root, index)}) + {provided = computed; expected = Valid_path (messages.root, index)}) >>? fun () -> ok ctxt -let adjust_commitments_count ctxt tx_rollup pkh ~(dir : [`Incr | `Decr]) = - let delta = match dir with `Incr -> 1 | `Decr -> -1 in +type direction = Incr | Decr + +let adjust_commitments_count ctxt tx_rollup pkh ~(dir : direction) = + let delta = match dir with Incr -> 1 | Decr -> -1 in Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) pkh >>=? fun (ctxt, commitment) -> let count = @@ -251,7 +257,7 @@ let add_commitment ctxt tx_rollup state pkh commitment = commitment.level commitment_hash >>?= fun state -> - adjust_commitments_count ctxt tx_rollup pkh ~dir:`Incr >>=? fun ctxt -> + adjust_commitments_count ctxt tx_rollup pkh ~dir:Incr >>=? fun ctxt -> return (ctxt, state, to_slash) let pending_bonded_commitments : @@ -322,7 +328,7 @@ let remove_commitment ctxt rollup state = fail (Internal_error "Missing finalized_at field")) >>=? fun () -> (* Decrement the bond count of the committer *) - adjust_commitments_count ctxt rollup commitment.committer ~dir:`Decr + adjust_commitments_count ctxt rollup commitment.committer ~dir:Decr >>=? fun ctxt -> (* We remove the commitment *) Storage.Tx_rollup.Commitment.remove (ctxt, rollup) tail @@ -350,7 +356,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state check_message_result ctxt commitment - (`Hash disputed_result) + (Hash disputed_result) ~path:disputed_result_path ~index:disputed_position >>?= fun ctxt -> @@ -362,7 +368,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state let expected = Tx_rollup_message_result_hash_repr.init in fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) - (Wrong_rejection_hash {provided = agreed; expected = `Hash expected}) + (Wrong_rejection_hash {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | Some pred_level -> ( Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) pred_level @@ -375,7 +381,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) (Wrong_rejection_hash - {provided = agreed; expected = `Hash expected}) + {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | None -> ( match Tx_rollup_state_repr.last_removed_commitment_hashes state with @@ -383,14 +389,14 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = last_hash) (Wrong_rejection_hash - {provided = agreed; expected = `Hash last_hash}) + {provided = agreed; expected = Hash last_hash}) >>=? fun () -> return ctxt | None -> fail (Internal_error "Missing commitment predecessor"))) else check_message_result ctxt commitment - (`Result agreed_result) + (Result agreed_result) ~path:agreed_result_path ~index:(disputed_position - 1) >>?= fun ctxt -> return ctxt diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.mli b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.mli index d273649533974..e588c662a69a2 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.mli +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_commitment_storage.mli @@ -28,11 +28,14 @@ (** This module introduces various functions to manipulate the storage related to commitments for transaction rollups. *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : Raw_context.t -> Tx_rollup_commitment_repr.Compact.t -> - [ `Hash of Tx_rollup_message_result_hash_repr.t - | `Result of Tx_rollup_message_result_repr.t ] -> + hash_or_result -> path:Tx_rollup_commitment_repr.Merkle.path -> index:int -> Raw_context.t tzresult diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_errors_repr.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_errors_repr.ml index 274c7924180d9..8dd6557057897 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_errors_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_errors_repr.ml @@ -25,6 +25,12 @@ (* *) (*****************************************************************************) +type error_or_commitment = Inbox | Commitment + +type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment_repr.Merkle.h * int + | Hash of Tx_rollup_message_result_hash_repr.t + type error += | Tx_rollup_already_exists of Tx_rollup_repr.t | Tx_rollup_does_not_exist of Tx_rollup_repr.t @@ -60,7 +66,7 @@ type error += length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -81,9 +87,7 @@ type error += } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash_repr.t; - expected : - [ `Valid_path of Tx_rollup_commitment_repr.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash_repr.t ]; + expected : valid_path_or_hash; } | Ticket_payload_size_limit_exceeded of {payload_size : int; limit : int} | Wrong_deposit_parameters @@ -401,14 +405,14 @@ let () = (Tag 0) ~title:"Inbox" (constant "inbox") - (function `Inbox -> Some () | _ -> None) - (fun () -> `Inbox); + (function Inbox -> Some () | _ -> None) + (fun () -> Inbox); case (Tag 1) ~title:"Commitment" (constant "commitment") - (function `Commitment -> Some () | _ -> None) - (fun () -> `Commitment); + (function Commitment -> Some () | _ -> None) + (fun () -> Commitment); ])) (req "provided" int31) (req "limit" int31)) @@ -583,16 +587,16 @@ let () = (Tag 0) ~title:"hash" Tx_rollup_message_result_hash_repr.encoding - (function `Hash h -> Some h | _ -> None) - (fun h -> `Hash h); + (function Hash h -> Some h | _ -> None) + (fun h -> Hash h); case (Tag 1) ~title:"valid_path" (obj2 (req "root" Tx_rollup_commitment_repr.Merkle_hash.encoding) (req "index" int31)) - (function `Valid_path (h, i) -> Some (h, i) | _ -> None) - (fun (h, i) -> `Valid_path (h, i)); + (function Valid_path (h, i) -> Some (h, i) | _ -> None) + (fun (h, i) -> Valid_path (h, i)); ]))) (function | Wrong_rejection_hash {provided; expected} -> Some (provided, expected) diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_gas.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_gas.ml index 41857f1c03e78..c5ff58d57203e 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_gas.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_gas.ml @@ -53,7 +53,7 @@ let check_path_cost element_size path_depth = hash_cost element_size >>? fun element_hash_cost -> (* At each step of the way, we hash 2 hashes together *) hash_cost 64 >>? fun hash_cost -> - let rec acc_hash_cost acc i = + let[@coq_struct "i_value"] rec acc_hash_cost acc i = if Compare.Int.(i <= 0) then acc else acc_hash_cost (hash_cost + acc) (i - 1) in diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.ml index a0aa2e90516ed..e8f8c0b79adb6 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.ml @@ -317,12 +317,126 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module Make (Context : CONTEXT) = struct +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 + + type ctxt_type + + type 'a m + + (** [apply_batch ctxt parameters batch] interprets the batch + {!Tx_rollup_l2_batch.V1.t}. + + By construction, a failing transaction will not affect the [ctxt] + and other transactions will still be interpreted. + That is, this function can only fail because of internals errors. + Otherwise, the errors that caused the transactions to fail can be + observed in the result (see {!Message_result.Batch_V1.t}). + + The counters are incremented when the operation is part of a transaction + that is correctly signed and whose every operations have the expected + counter. In particular, the result of the application is not important + (i.e. the counters are updated even if the transaction failed). + + In addition, the list of withdrawals resulting from each + layer2-to-layer1 transfer message in the batch is returned. + *) + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m + + (** [check_signature ctxt batch] asserts that [batch] is correctly signed. + + We recall that [batch] may contain indexes, that is integers which + replace larger values. The [signer] field of the + {!Tx_rollup_l2_batch.operation} type is concerned. This field is either + the public key to be used to check the signature, or an index. + In case of the public key, [check_signature] will check whether or not + the related {!Tx_rollup_l2_address.t} has already an index assigned, + and allocate one if not. + + Overall, [check_signature] returns the revised context, the list of + newly allocated indexes, and an updated version of the batches where + all [signer] field have been replaced by valid indexes. + + {b Note:} What a user is expected to sign is the version of the + operation it sends to the network. This is potentially unsafe, + because it means the user signs indexes, not addresses nor + ticket hashes. This poses two threats: Tezos reorganization, + and malicious provider of indexes. A Tezos reorganization may + imply that an index allocated to one address in a given branch + is allocated to another address in another branch. We deal with + this issue by making the rollup node aware of the Tezos level at + each time an index is allocated. This allows to implement a RPC that + can safely tell a client to use either the full value or the index, + thanks to Tenderbake finality. To prevent the rollup node to lie, + we will make the rollup node provide Merkle proofs that allows the + client to verify that the index is correct. + *) + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end + +module type S = sig + type ctxt_type + + type 'a m + + (** The operations are versioned (see {!Tx_rollup_l2_batch}), + so their interpretations are. *) + + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m + + (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 + address in [ctxt]. + + This function can fail if the [deposit.amount] is not strictly-positive. + + If the [deposit] causes an error, then a withdrawal returning + the funds to the deposit's sender is returned. + *) + val apply_deposit : + ctxt_type -> + Tx_rollup_message.deposit -> + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + + (** [apply_message ctxt parameters message] interprets the [message] in the + [ctxt]. + + That is, + + {ul {li Deposit tickets if the message is a deposit. } + {li Decodes the batch and interprets it for the + correct batch version. }} + + The function can fail with {!Invalid_batch_encoding} if it's not able + to decode the batch. + + The function can also return errors from subsequent functions, + see {!apply_deposit} and batch interpretations for various versions. + + The list of withdrawals in the message result followed the ordering + of the contents in the message. + *) + val apply_message : + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m +end + +module Make (Context : CONTEXT) : + S with type ctxt_type = Context.t and type 'a m := 'a Context.m = struct open Context open Syntax open Message_result - type ctxt = Context.t + type ctxt_type = Context.t (** {3. Indexes. } *) @@ -336,8 +450,8 @@ module Make (Context : CONTEXT) = struct | Right v -> ( let+ (ctxt, created, idx) = get_or_associate_index ctxt v in match created with - | `Existed -> (ctxt, indexes, idx) - | `Created -> (ctxt, add_index indexes (v, idx), idx)) + | Existed -> (ctxt, indexes, idx) + | Created -> (ctxt, add_index indexes (v, idx), idx)) | Left i -> return (ctxt, indexes, i) let address_index ctxt indexes indexable = @@ -372,7 +486,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata ctxt idx] returns the metadata associated to [idx] in [ctxt]. It must have an associated metadata in the context, otherwise, something went wrong in {!check_signature}. *) - let get_metadata : ctxt -> address_index -> metadata m = + let get_metadata : ctxt_type -> address_index -> metadata m = fun ctxt idx -> let open Address_metadata in let* metadata = get ctxt idx in @@ -382,7 +496,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata_signer] gets the metadata for a signer using {!get_metadata}. It transforms a signer index to an address one. *) - let get_metadata_signer : ctxt -> Signer_indexable.index -> metadata m = + let get_metadata_signer : ctxt_type -> Signer_indexable.index -> metadata m = fun ctxt signer_idx -> get_metadata ctxt (address_of_signer_index signer_idx) (** [transfers ctxt source_idx destination_idx tidx amount] transfers [amount] @@ -402,7 +516,8 @@ module Make (Context : CONTEXT) = struct we only handle the creation part (i.e. in the layer2) in this module. *) let deposit ctxt aidx tidx amount = Ticket_ledger.credit ctxt tidx aidx amount - module Batch_V1 = struct + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m = struct open Tx_rollup_l2_batch.V1 (** [operation_with_signer_index ctxt indexes op] takes an operation @@ -419,10 +534,10 @@ module Make (Context : CONTEXT) = struct {b Note:} If the context already contains all the required information, we only read from it. *) let operation_with_signer_index : - ctxt -> + ctxt_type -> indexes -> ('signer, 'content) operation -> - (ctxt + (ctxt_type * indexes * (Indexable.index_only, 'content) operation * Bls_signature.pk) @@ -445,7 +560,7 @@ module Make (Context : CONTEXT) = struct (* If the address is created, we add it to [indexes]. *) match created with - | `Existed -> + | Existed -> (* If the public key existed in the context, it should not be added in [indexes]. However, the metadata might not have been initialized for the public key. Especially during @@ -463,7 +578,7 @@ module Make (Context : CONTEXT) = struct Address_metadata.init_with_public_key ctxt idx signer_pk in return (ctxt, indexes, signer_pk, idx) - | `Created -> + | Created -> (* If the index is created, we need to add to indexes and initialize the metadata. *) let indexes = @@ -542,9 +657,9 @@ module Make (Context : CONTEXT) = struct return (ctxt, indexes, transmitted, List.rev rev_ops) let check_signature : - ctxt -> + ctxt_type -> ('signer, 'content) t -> - (ctxt * indexes * (Indexable.index_only, 'content) t) m = + (ctxt_type * indexes * (Indexable.index_only, 'content) t) m = fun ctxt ({contents = transactions; aggregated_signature} as batch) -> let* (ctxt, indexes, transmitted, rev_new_transactions) = list_fold_left_m @@ -578,11 +693,11 @@ module Make (Context : CONTEXT) = struct {li The ticket exchanged index.}} *) let apply_operation_content : - ctxt -> + ctxt_type -> indexes -> Signer_indexable.index -> 'content operation_content -> - (ctxt * indexes * Tx_rollup_withdraw.t option) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t option) m = fun ctxt indexes source_idx op_content -> match op_content with | Withdraw {destination = claimer; ticket_hash; qty = amount} -> @@ -614,7 +729,8 @@ module Make (Context : CONTEXT) = struct (** [check_counter ctxt signer counter] asserts that the provided [counter] is the successor of the one associated to the [signer] in the [ctxt]. *) let check_counter : - ctxt -> Indexable.index_only Signer_indexable.t -> int64 -> unit m = + ctxt_type -> Indexable.index_only Signer_indexable.t -> int64 -> unit m + = fun ctxt signer counter -> let* metadata = get_metadata_signer ctxt signer in fail_unless @@ -629,10 +745,10 @@ module Make (Context : CONTEXT) = struct (** [apply_operation ctxt indexes op] checks the counter validity for the [op.signer] with {!check_counter}, and then calls {!apply_operation_content} for each content in [op]. *) let apply_operation : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) operation -> - (ctxt * indexes * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t list) m = fun ctxt indexes {signer; counter; contents} -> (* Before applying any operation, we check the counter *) let* () = check_counter ctxt signer counter in @@ -655,12 +771,14 @@ module Make (Context : CONTEXT) = struct is left untouched. *) let apply_transaction : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) transaction -> - (ctxt * indexes * transaction_result * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * transaction_result * Tx_rollup_withdraw.t list) m + = fun initial_ctxt initial_indexes transaction -> - let rec fold (ctxt, prev_indexes, withdrawals) index ops = + let rec fold env index ops = + let (ctxt, prev_indexes, withdrawals) = env in match ops with | [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals) | op :: rst -> @@ -690,8 +808,17 @@ module Make (Context : CONTEXT) = struct *) let update_counters ctxt status transaction = match status with - | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt - | Transaction_failure _ | Transaction_success -> + | Transaction_failure {reason; _} -> ( + match reason with + | Counter_mismatch _ -> return ctxt + | _ -> + list_fold_left_m + (fun ctxt (op : (Indexable.index_only, _) operation) -> + Address_metadata.incr_counter ctxt + @@ address_of_signer_index op.signer) + ctxt + transaction) + | Transaction_success -> list_fold_left_m (fun ctxt (op : (Indexable.index_only, _) operation) -> Address_metadata.incr_counter ctxt @@ -700,10 +827,10 @@ module Make (Context : CONTEXT) = struct transaction let apply_batch : - ctxt -> + ctxt_type -> parameters -> (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = fun ctxt parameters batch -> let* (ctxt, indexes, batch) = check_signature ctxt batch in let {contents; _} = batch in @@ -736,9 +863,9 @@ module Make (Context : CONTEXT) = struct end let apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * deposit_result * Tx_rollup_withdraw.t option) m = + (ctxt_type * deposit_result * Tx_rollup_withdraw.t option) m = fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} -> let apply_deposit () = let* (ctxt, indexes, aidx) = @@ -763,7 +890,10 @@ module Make (Context : CONTEXT) = struct return (initial_ctxt, Deposit_failure reason, Some withdrawal)) let apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m = + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m = fun ctxt parameters msg -> let open Tx_rollup_message in match msg with diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.mli index 44619b09fe58b..33e8af74ad1f3 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.mli +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_apply.mli @@ -122,73 +122,80 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module Make (Context : CONTEXT) : sig - open Context +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 - type ctxt = t + type ctxt_type + + type 'a m + + (** [apply_batch ctxt parameters batch] interprets the batch + {!Tx_rollup_l2_batch.V1.t}. + + By construction, a failing transaction will not affect the [ctxt] + and other transactions will still be interpreted. + That is, this function can only fail because of internals errors. + Otherwise, the errors that caused the transactions to fail can be + observed in the result (see {!Message_result.Batch_V1.t}). + + The counters are incremented when the operation is part of a transaction + that is correctly signed and whose every operations have the expected + counter. In particular, the result of the application is not important + (i.e. the counters are updated even if the transaction failed). + + In addition, the list of withdrawals resulting from each + layer2-to-layer1 transfer message in the batch is returned. + *) + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m + + (** [check_signature ctxt batch] asserts that [batch] is correctly signed. + + We recall that [batch] may contain indexes, that is integers which + replace larger values. The [signer] field of the + {!Tx_rollup_l2_batch.operation} type is concerned. This field is either + the public key to be used to check the signature, or an index. + In case of the public key, [check_signature] will check whether or not + the related {!Tx_rollup_l2_address.t} has already an index assigned, + and allocate one if not. + + Overall, [check_signature] returns the revised context, the list of + newly allocated indexes, and an updated version of the batches where + all [signer] field have been replaced by valid indexes. + + {b Note:} What a user is expected to sign is the version of the + operation it sends to the network. This is potentially unsafe, + because it means the user signs indexes, not addresses nor + ticket hashes. This poses two threats: Tezos reorganization, + and malicious provider of indexes. A Tezos reorganization may + imply that an index allocated to one address in a given branch + is allocated to another address in another branch. We deal with + this issue by making the rollup node aware of the Tezos level at + each time an index is allocated. This allows to implement a RPC that + can safely tell a client to use either the full value or the index, + thanks to Tenderbake finality. To prevent the rollup node to lie, + we will make the rollup node provide Merkle proofs that allows the + client to verify that the index is correct. + *) + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end + +module type S = sig + type ctxt_type + + type 'a m (** The operations are versioned (see {!Tx_rollup_l2_batch}), so their interpretations are. *) - module Batch_V1 : sig - open Tx_rollup_l2_batch.V1 - - (** [apply_batch ctxt parameters batch] interprets the batch - {!Tx_rollup_l2_batch.V1.t}. - - By construction, a failing transaction will not affect the [ctxt] - and other transactions will still be interpreted. - That is, this function can only fail because of internals errors. - Otherwise, the errors that caused the transactions to fail can be - observed in the result (see {!Message_result.Batch_V1.t}). - - The counters are incremented when the operation is part of a transaction - that is correctly signed and whose every operations have the expected - counter. In particular, the result of the application is not important - (i.e. the counters are updated even if the transaction failed). - - In addition, the list of withdrawals resulting from each - layer2-to-layer1 transfer message in the batch is returned. - *) - val apply_batch : - ctxt -> - parameters -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m - - (** [check_signature ctxt batch] asserts that [batch] is correctly signed. - - We recall that [batch] may contain indexes, that is integers which - replace larger values. The [signer] field of the - {!Tx_rollup_l2_batch.operation} type is concerned. This field is either - the public key to be used to check the signature, or an index. - In case of the public key, [check_signature] will check whether or not - the related {!Tx_rollup_l2_address.t} has already an index assigned, - and allocate one if not. - - Overall, [check_signature] returns the revised context, the list of - newly allocated indexes, and an updated version of the batches where - all [signer] field have been replaced by valid indexes. - - {b Note:} What a user is expected to sign is the version of the - operation it sends to the network. This is potentially unsafe, - because it means the user signs indexes, not addresses nor - ticket hashes. This poses two threats: Tezos reorganization, - and malicious provider of indexes. A Tezos reorganization may - imply that an index allocated to one address in a given branch - is allocated to another address in another branch. We deal with - this issue by making the rollup node aware of the Tezos level at - each time an index is allocated. This allows to implement a RPC that - can safely tell a client to use either the full value or the index, - thanks to Tenderbake finality. To prevent the rollup node to lie, - we will make the rollup node provide Merkle proofs that allows the - client to verify that the index is correct. - *) - val check_signature : - ctxt -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m - end + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 address in [ctxt]. @@ -199,9 +206,9 @@ module Make (Context : CONTEXT) : sig the funds to the deposit's sender is returned. *) val apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m (** [apply_message ctxt parameters message] interprets the [message] in the [ctxt]. @@ -222,5 +229,11 @@ module Make (Context : CONTEXT) : sig of the contents in the message. *) val apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m end + +module Make (Context : CONTEXT) : + S with type ctxt_type = Context.t and type 'a m := 'a Context.m diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.ml index 210668f9a9847..c879022d0e0a4 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.ml @@ -144,7 +144,7 @@ module V1 = struct let operation_content_encoding = Data_encoding.Compact.make ~tag_size compact_operation_content - let compact_operation encoding_signer = + let compact_operation_raw encoding_signer = Data_encoding.Compact.( conv (fun {signer; counter; contents} -> (signer, counter, contents)) @@ -154,30 +154,32 @@ module V1 = struct (req "counter" int64) (req "contents" @@ list ~bits:4 operation_content_encoding)) - let operation_encoding encoding_signer = - Data_encoding.Compact.(make ~tag_size (compact_operation encoding_signer)) + let operation_encoding_raw encoding_signer = + Data_encoding.Compact.( + make ~tag_size (compact_operation_raw encoding_signer)) - let compact_transaction encoding_signer = - Data_encoding.Compact.list ~bits:8 (operation_encoding encoding_signer) + let compact_transaction_raw encoding_signer = + Data_encoding.Compact.list ~bits:8 (operation_encoding_raw encoding_signer) - let transaction_encoding : + let transaction_encoding_raw : 'a -> ('b, Indexable.unknown) transaction Data_encoding.t = fun encoding_signer -> - Data_encoding.Compact.(make ~tag_size (compact_transaction encoding_signer)) + Data_encoding.Compact.( + make ~tag_size (compact_transaction_raw encoding_signer)) let compact_signer_index = Data_encoding.Compact.(conv Indexable.to_int32 Indexable.index_exn int32) let compact_signer_either = Signer_indexable.compact - let compact_operation = compact_operation compact_signer_either + let compact_operation = compact_operation_raw compact_signer_either let compact_transaction_signer_index = - compact_transaction compact_signer_index + compact_transaction_raw compact_signer_index - let compact_transaction = compact_transaction compact_signer_either + let compact_transaction = compact_transaction_raw compact_signer_either - let transaction_encoding = transaction_encoding compact_signer_either + let transaction_encoding = transaction_encoding_raw compact_signer_either let compact ~bits : (Indexable.unknown, Indexable.unknown) t Data_encoding.Compact.t = diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.mli b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.mli index e59261c998aad..ef323fe52c745 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.mli +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_batch.mli @@ -77,21 +77,7 @@ type signer = (** A signer identified by a layer-2 address. Each such adress is in turn identified with a BLS public key. *) -module Signer_indexable : sig - type nonrec 'state t = ('state, signer) Indexable.t - - type nonrec index = signer Indexable.index - - type nonrec value = signer Indexable.value - - type either = signer Indexable.either - - val encoding : either Data_encoding.t - - val compare : either -> either -> int - - val pp : Format.formatter -> either -> unit -end +module Signer_indexable : Indexable.INDEXABLE with type v_t := signer (** {1 Layer-2 Batches Definitions} *) diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context.ml index ae06d5b2330af..6b6f391ef5116 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context.ml @@ -119,7 +119,7 @@ let packed_key_encoding : packed_key Data_encoding.t = underlying storage. *) let value_encoding : type a. a key -> a Data_encoding.t = let open Data_encoding in - function + function[@coq_match_gadt_with_result] | Address_metadata _ -> metadata_encoding | Address_count -> int32 | Address_index _ -> Tx_rollup_l2_address.Indexable.index_encoding @@ -175,7 +175,7 @@ struct type 'a m = 'a S.m - module Syntax = struct + module Syntax : SYNTAX with type 'a m := 'a m = struct include S.Syntax let ( let*? ) res f = @@ -274,7 +274,12 @@ struct end end - module Address_index = struct + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Address_count in @@ -301,17 +306,22 @@ struct let open Syntax in let* index_opt = get ctxt addr in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ (ctxt, idx) = associate_index ctxt addr in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Address_count count end end - module Ticket_index = struct + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Ticket_count in @@ -338,17 +348,18 @@ struct let open Syntax in let* index_opt = get ctxt ticket in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ (ctxt, idx) = associate_index ctxt ticket in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Ticket_count count end end - module Ticket_ledger = struct + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m = + struct let get_opt ctxt tidx aidx = get ctxt (Ticket_ledger (tidx, aidx)) let get ctxt tidx aidx = diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context_sig.ml index ba8d16138f325..a706f3d14673d 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_context_sig.ml @@ -157,198 +157,137 @@ let () = (function Counter_overflow -> Some () | _ -> None) (fun () -> Counter_overflow) -(** This module type describes the API of the [Tx_rollup] context, - which is used to implement the semantics of the L2 operations. *) -module type CONTEXT = sig - (** The state of the [Tx_rollup] context. - - The context provides a type-safe, functional API to interact - with the state of a transaction rollup. The functions of this - module, manipulating and creating values of type [t] are called - “context operations” afterwards. *) - type t +type created_existed = Created | Existed - (** The monad used by the context. - - {b Note:} It is likely to be the monad of the underlying - storage. In the case of the proof verifier, as it is expected to - be run into the L1, the monad will also be used to perform gas - accounting. This is why all the functions of this module type - needs to be inside the monad [m]. *) +(** The necessary monadic operators the storage monad is required to + provide. *) +module type SYNTAX = sig type 'a m - (** The necessary monadic operators the storage monad is required to - provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - (** [let*?] is for binding the value from Result-only - expressions into the storage monad. *) - val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m + (** [let*?] is for binding the value from Result-only + expressions into the storage monad. *) + val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m - (** [fail err] shortcuts the current computation by raising an - error. + (** [fail err] shortcuts the current computation by raising an + error. - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) - val fail_unless : bool -> error -> unit m + (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) + val fail_unless : bool -> error -> unit m - (** [fail_when cond err] raises [err] iff [cond] is [true]. *) - val fail_when : bool -> error -> unit m - end - - (** [bls_aggregate_verify] allows to verify the aggregated signature - of a batch. *) - val bls_verify : (Bls_signature.pk * bytes) list -> signature -> bool m + (** [fail_when cond err] raises [err] iff [cond] is [true]. *) + val fail_when : bool -> error -> unit m +end - (** The metadata associated to an address. *) - module Address_metadata : sig - (** [get ctxt idx] returns the current metadata associated to the - address indexed by [idx]. *) - val get : t -> address_index -> metadata option m +module type ADDRESS_METADATA = sig + type t - (** [incr_counter ctxt idx] increments the counter of the - address indexed by [idx]. + type 'a m - This function can fail with [Counter_overflow] iff the counter - has reached the [Int64.max_int] limit. + (** [get ctxt idx] returns the current metadata associated to the + address indexed by [idx]. *) + val get : t -> address_index -> metadata option m - This function can fail with [Unknown_address_index] if [idx] - has not been associated with a layer-2 address already. *) - val incr_counter : t -> address_index -> t m + (** [incr_counter ctxt idx] increments the counter of the + address indexed by [idx]. - (** [init_with_public_key ctxt idx pk] initializes the metadata - associated to the address indexed by [idx]. + This function can fail with [Counter_overflow] iff the counter + has reached the [Int64.max_int] limit. - This can fails with [Metadata_already_initialized] if this - function has already been called with [idx]. *) - val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m + This function can fail with [Unknown_address_index] if [idx] + has not been associated with a layer-2 address already. *) + val incr_counter : t -> address_index -> t m - (**/**) + (** [init_with_public_key ctxt idx pk] initializes the metadata + associated to the address indexed by [idx]. - module Internal_for_tests : sig - val set : t -> address_index -> metadata -> t m - end - end + This can fails with [Metadata_already_initialized] if this + function has already been called with [idx]. *) + val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m - (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + (**/**) - Addresses are supposed to be associated to a {!address_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time an address is used in a layer2 - operation, we associate it to a address_index that should be use - in future layer2 operations. - *) - module Address_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in - the context. *) - val init_counter : t -> t m - - (** [get ctxt addr] returns the index associated to [addr], if - any. *) - val get : t -> Tx_rollup_l2_address.t -> address_index option m - - (** [get_or_associate_index ctxt addr] associates a fresh [address_index] - to [addr], and returns it. If the [addr] has already been associated to - an index, it returns it. - It also returns the information on whether the index was created or - already existed. - - This function can fail with [Too_many_l2_addresses] iff there - is no fresh index available. *) - val get_or_associate_index : - t -> - Tx_rollup_l2_address.t -> - (t * [`Created | `Existed] * address_index) m + module Internal_for_tests : sig + val set : t -> address_index -> metadata -> t m + end +end - (** [count ctxt] returns the number of addresses that have been - involved in the transaction rollup. *) - val count : t -> int32 m +module type INDEX = sig + type t - (**/**) + type 'a m - module Internal_for_tests : sig - (** [set ctxt count] sets the [count] in [ctxt]. It is used to test - the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end - end + type hash - (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + type index - Ticket hashes are supposed to be associated to a {!ticket_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time a ticket hash is used in a layer2 - operation, we associate it to a ticket_index that should be use - in future layer2 operations. - *) - module Ticket_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in + (** [init_counter ctxt] writes the default counter (i.e. [0L]) in the context. *) - val init_counter : t -> t m + val init_counter : t -> t m - (** [get ctxt ticket] returns the index associated to [ticket], if + (** [get ctxt hash] returns the index associated to [hash], if any. *) - val get : t -> Alpha_context.Ticket_hash.t -> ticket_index option m + val get : t -> hash -> index option m - (** [get_or_associate_index ctxt ticket] associates a fresh [ticket_index] - to [ticket], and returns it. If the [ticket] has already been associated + (** [get_or_associate_index ctxt hash] associates a fresh [index] + to [hash], and returns it. If the [hash] has already been associated to an index, it returns it. It also returns the information on whether the index was created or already existed. This function can fail with [Too_many_l2_tickets] iff there is no fresh index available. *) - val get_or_associate_index : - t -> - Alpha_context.Ticket_hash.t -> - (t * [`Created | `Existed] * ticket_index) m + val get_or_associate_index : t -> hash -> (t * created_existed * index) m - (** [count ctxt] returns the number of tickets that have been + (** [count ctxt] returns the number of tickets that have been involved in the transaction rollup. *) - val count : t -> int32 m + val count : t -> int32 m - (**/**) + (**/**) - module Internal_for_tests : sig - (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test + module Internal_for_tests : sig + (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end + val set_count : t -> int32 -> t m end +end - (** The ledger of the layer 2 where are registered the amount of a - given ticket a L2 [account] has in its possession. *) - module Ticket_ledger : sig - (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] +module type TICKET_LEDGER = sig + type t + + type 'a m + + (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] owns. {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. The function will return zero when the address has no such ticket. *) - val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m + val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m - (** [credit ctxt tidx aidx qty] updates the ledger to + (** [credit ctxt tidx aidx qty] updates the ledger to increase the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -362,9 +301,9 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - (** [spend ctxt tidx aidx qty] updates the ledger to + (** [spend ctxt tidx aidx qty] updates the ledger to decrease the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -374,11 +313,76 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - module Internal_for_tests : sig - val get_opt : - t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m - end + module Internal_for_tests : sig + val get_opt : + t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m end end + +(** This module type describes the API of the [Tx_rollup] context, + which is used to implement the semantics of the L2 operations. *) +module type CONTEXT = sig + (** The state of the [Tx_rollup] context. + + The context provides a type-safe, functional API to interact + with the state of a transaction rollup. The functions of this + module, manipulating and creating values of type [t] are called + “context operations” afterwards. *) + type t + + (** The monad used by the context. + + {b Note:} It is likely to be the monad of the underlying + storage. In the case of the proof verifier, as it is expected to + be run into the L1, the monad will also be used to perform gas + accounting. This is why all the functions of this module type + needs to be inside the monad [m]. *) + type 'a m + + module Syntax : SYNTAX with type 'a m := 'a m + + (** [bls_aggregate_verify] allows to verify the aggregated signature + of a batch. *) + val bls_verify : + (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m + + (** The metadata associated to an address. *) + module Address_metadata : + ADDRESS_METADATA with type t := t and type 'a m := 'a m + + (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + + Addresses are supposed to be associated to a {!address_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time an address is used in a layer2 + operation, we associate it to a address_index that should be use + in future layer2 operations. + *) + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index + + (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + + Ticket hashes are supposed to be associated to a {!ticket_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time a ticket hash is used in a layer2 + operation, we associate it to a ticket_index that should be use + in future layer2 operations. + *) + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index + + (** The ledger of the layer 2 where are registered the amount of a + given ticket a L2 [account] has in its possession. *) + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m +end diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_storage_sig.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_storage_sig.ml index 4a81f9cd41808..2b62542033cea 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_storage_sig.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_storage_sig.ml @@ -25,6 +25,39 @@ (* *) (*****************************************************************************) +(** The necessary monadic operators the monad of the storage backend + is required to provide. *) +module type SYNTAX = sig + type t + + type 'a m + + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + + (** [fail err] shortcuts the current computation by raising an + error. + + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m + + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m + + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m +end + (** This module type is the minimal API a storage backend has to implement to be compatible with the [Tx_rollup] layer-2 implementation. @@ -44,34 +77,7 @@ module type STORAGE = sig (** The monad of the storage backend. *) type 'a m - (** The necessary monadic operators the monad of the storage backend - is required to provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - - (** [fail err] shortcuts the current computation by raising an - error. - - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m - - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m - - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - end + module Syntax : SYNTAX with type t := t and type 'a m := 'a m (** [get storage key] returns the value stored in [storage] for [key], if it exists. Returns [None] if it does not. *) diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_verifier.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_verifier.ml index 4773ea6047990..546ed98aadf8a 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_verifier.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_l2_verifier.ml @@ -77,7 +77,9 @@ module Verifier_storage : type 'a m = ('a, error) result Lwt.t - module Syntax = struct + module Syntax : + Tx_rollup_l2_storage_sig.SYNTAX with type t := t and type 'a m := 'a m = + struct let ( let* ) = ( >>=? ) let ( let+ ) = ( >|=? ) diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_message_repr.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_message_repr.ml index c1a50a995be8f..7913ddcd92ae4 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_message_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_message_repr.ml @@ -94,7 +94,8 @@ let pp fmt = amount:%a@]" Signature.Public_key_hash.pp sender - Tx_rollup_l2_address.Indexable.pp + (Tx_rollup_l2_address.Indexable.pp + [@coq_implicit "state" "Tx_rollup_l2_address.t"]) destination Ticket_hash_repr.pp ticket_hash diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_parameters.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_parameters.ml index 7c93e0a7f75e9..5832a20262b31 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_parameters.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_parameters.ml @@ -35,8 +35,10 @@ let get_deposit_parameters : (a, comparable) Script_typed_ir.ty -> a -> deposit_parameters tzresult = fun ty contents -> let open Script_typed_ir in - match (ty, contents) with + match[@coq_match_gadt] (ty, contents) with | ( Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _), - (ticket, l2_destination) ) -> + (contents : + _ Script_typed_ir.ticket * Script_typed_ir.tx_rollup_l2_address) ) -> + let (ticket, l2_destination) = contents in ok {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination} | _ -> error Alpha_context.Tx_rollup_errors.Wrong_deposit_parameters diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_repr.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_repr.ml index 2623a090fe3ec..8782ee21d6068 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_repr.ml @@ -83,7 +83,9 @@ let in_memory_size _ = let to_b58check rollup = Hash.to_b58check rollup let of_b58check_opt s = - match Base58.decode s with Some (Hash.Data hash) -> Some hash | _ -> None + match Base58.decode s with + | Some data -> ( match data with Hash.Data hash -> Some hash | _ -> None) + | _ -> None let of_b58check s = match of_b58check_opt s with diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_state_repr.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_state_repr.ml index d7a7409c6f5ad..2c3b8f2265ddc 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_state_repr.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_state_repr.ml @@ -430,7 +430,7 @@ let update_burn_per_byte_helper : be the maximum amount. *) | Error _ -> {state with burn_per_byte = Tez_repr.max_mutez; inbox_ema} -let rec update_burn_per_byte : +let[@coq_struct "elapsed"] rec update_burn_per_byte : t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t = fun state ~elapsed ~factor ~final_size ~hard_limit -> (* factor is expected to be a low number ~ 100 *) diff --git a/src/proto_013_PtJakart/lib_protocol/tx_rollup_ticket.ml b/src/proto_013_PtJakart/lib_protocol/tx_rollup_ticket.ml index 066549e158d09..d853cf0428737 100644 --- a/src/proto_013_PtJakart/lib_protocol/tx_rollup_ticket.ml +++ b/src/proto_013_PtJakart/lib_protocol/tx_rollup_ticket.ml @@ -31,8 +31,9 @@ let parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt = Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data + [@coq_implicit "a" "__Ex_comparable_ty_'a"]) ctxt contents_type (Micheline.root contents) @@ -46,8 +47,9 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data + [@coq_implicit "a" "__Ex_comparable_ty_'a"]) ctxt contents_type (Micheline.root contents) diff --git a/src/proto_013_PtJakart/lib_protocol/voting_services.ml b/src/proto_013_PtJakart/lib_protocol/voting_services.ml index 2422274c5d52b..b005d4d47a9c2 100644 --- a/src/proto_013_PtJakart/lib_protocol/voting_services.ml +++ b/src/proto_013_PtJakart/lib_protocol/voting_services.ml @@ -121,9 +121,6 @@ let register () = Vote.find_current_proposal ctxt) ; register0 ~chunked:false S.total_voting_power (fun ctxt () () -> Vote.get_total_voting_power_free ctxt) - [@@coq_axiom_with_reason - "disabled because we would need to re-create the error e in order to have \ - different polymorphic variables"] let ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () () -- GitLab From a1c623da832a95ccee4a448f74fb9acbb9b6e0c8 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 24 Aug 2022 11:44:21 +0200 Subject: [PATCH 2/3] Proto: more for coq-of-ocaml proto J --- src/lib_context/sigs/context.ml | 4 + src/lib_crypto/blake2B.ml | 15 +- src/lib_crypto/blake2B.mli | 16 +- .../environment_context_intf.ml | 2 + src/lib_protocol_environment/sigs/v4.ml | 6 +- .../sigs/v4/context.mli | 6 +- src/lib_protocol_environment/sigs/v5.in.ml | 117 +++++----- src/lib_protocol_environment/sigs/v5.ml | 211 +++++++++--------- .../sigs/v5/bounded.mli | 2 +- .../sigs/v5/compare.mli | 1 + .../sigs/v5/context.mli | 1 + .../sigs/v5/data_encoding.mli | 4 +- src/lib_protocol_environment/sigs/v5/map.mli | 4 +- .../lib_protocol/script_interpreter.ml | 2 +- 14 files changed, 201 insertions(+), 190 deletions(-) diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index 6b38c115c8dd9..b4bf05725daf3 100644 --- a/src/lib_context/sigs/context.ml +++ b/src/lib_context/sigs/context.ml @@ -27,6 +27,10 @@ (** The tree depth of a fold. See the [fold] function for more information. *) type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] +(** The order in which we fold over elements. See the [View.fold] function for + more information. *) +type order = [`Sorted | `Undefined] + module type VIEW = sig (** The type for context views. *) type t diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml index 6ae5f3ee06693..278a022033a31 100644 --- a/src/lib_crypto/blake2B.ml +++ b/src/lib_crypto/blake2B.ml @@ -314,20 +314,13 @@ end let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig +module type To_bytes = sig type t val to_bytes : t -> Bytes.t -end) = +end + +module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) = struct include Make (R) (K) diff --git a/src/lib_crypto/blake2B.mli b/src/lib_crypto/blake2B.mli index 044734007acd6..021a5201e74de 100644 --- a/src/lib_crypto/blake2B.mli +++ b/src/lib_crypto/blake2B.mli @@ -68,20 +68,14 @@ module Make (Register : Register) (Name : PrefixedName) : S.HASH (**/**) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig +module type To_bytes = sig type t val to_bytes : t -> Bytes.t -end) : S.MERKLE_TREE with type elt = Contents.t +end + +module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) : + S.MERKLE_TREE with type elt = Contents.t module Generic_Merkle_tree (H : sig type t diff --git a/src/lib_protocol_environment/environment_context_intf.ml b/src/lib_protocol_environment/environment_context_intf.ml index 1ce6bfaca4360..d5e9f07051018 100644 --- a/src/lib_protocol_environment/environment_context_intf.ml +++ b/src/lib_protocol_environment/environment_context_intf.ml @@ -208,6 +208,8 @@ module V3 = V2 module V4 = struct type depth = V3.depth + type order = [`Sorted | `Undefined] + module type VIEW = sig include V3.VIEW diff --git a/src/lib_protocol_environment/sigs/v4.ml b/src/lib_protocol_environment/sigs/v4.ml index eb28f77518fab..8bd349fdd096d 100644 --- a/src/lib_protocol_environment/sigs/v4.ml +++ b/src/lib_protocol_environment/sigs/v4.ml @@ -7915,6 +7915,10 @@ end (** The tree depth of a fold. See the [fold] function for more information. *) type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] +(** The order in which we fold over elements. See the [fold] function for more + information. *) +type order = [`Sorted | `Undefined] + module type VIEW = sig (** The type for context views. *) type t @@ -7997,7 +8001,7 @@ module type VIEW = sig ?depth:depth -> t -> key -> - order:[`Sorted | `Undefined] -> + order:order -> init:'a -> f:(key -> tree -> 'a -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/sigs/v4/context.mli b/src/lib_protocol_environment/sigs/v4/context.mli index 6114a50ed3948..6447c03f7e1b0 100644 --- a/src/lib_protocol_environment/sigs/v4/context.mli +++ b/src/lib_protocol_environment/sigs/v4/context.mli @@ -31,6 +31,10 @@ (** The tree depth of a fold. See the [fold] function for more information. *) type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] +(** The order in which we fold over elements. See the [fold] function for more + information. *) +type order = [`Sorted | `Undefined] + module type VIEW = sig (** The type for context views. *) type t @@ -113,7 +117,7 @@ module type VIEW = sig ?depth:depth -> t -> key -> - order:[`Sorted | `Undefined] -> + order:order -> init:'a -> f:(key -> tree -> 'a -> 'a Lwt.t) -> 'a Lwt.t diff --git a/src/lib_protocol_environment/sigs/v5.in.ml b/src/lib_protocol_environment/sigs/v5.in.ml index 26a308b3df455..76bb197ef924b 100644 --- a/src/lib_protocol_environment/sigs/v5.in.ml +++ b/src/lib_protocol_environment/sigs/v5.in.ml @@ -3,127 +3,130 @@ module type T = sig include Tezos_protocol_environment_sigs_internals.CamlinternalFormatBasics end - module Pervasives : [%sig "v5/pervasives.mli"] + module Pervasives : [%sig "v5/pervasives.mli"] [@@coq_plain_module] open Pervasives - module Either : [%sig "v5/either.mli"] + module Either : [%sig "v5/either.mli"] [@@coq_plain_module] - module String : [%sig "v5/string.mli"] + module String : [%sig "v5/string.mli"] [@@coq_plain_module] - module Char : [%sig "v5/char.mli"] + module Char : [%sig "v5/char.mli"] [@@coq_plain_module] - module Bytes : [%sig "v5/bytes.mli"] + module Bytes : [%sig "v5/bytes.mli"] [@@coq_plain_module] - module Int32 : [%sig "v5/int32.mli"] + module Int32 : [%sig "v5/int32.mli"] [@@coq_plain_module] - module Int64 : [%sig "v5/int64.mli"] + module Int64 : [%sig "v5/int64.mli"] [@@coq_plain_module] - module Format : [%sig "v5/format.mli"] + module Format : [%sig "v5/format.mli"] [@@coq_plain_module] - module Logging : [%sig "v5/logging.mli"] + module Logging : [%sig "v5/logging.mli"] [@@coq_plain_module] - module Hex : [%sig "v5/hex.mli"] + module Hex : [%sig "v5/hex.mli"] [@@coq_plain_module] - module Z : [%sig "v5/z.mli"] + module Z : [%sig "v5/z.mli"] [@@coq_plain_module] - module Lwt : [%sig "v5/lwt.mli"] + module Lwt : [%sig "v5/lwt.mli"] [@@coq_plain_module] - module Data_encoding : [%sig "v5/data_encoding.mli"] + module Data_encoding : [%sig "v5/data_encoding.mli"] [@@coq_plain_module] - module Raw_hashes : [%sig "v5/raw_hashes.mli"] + module Raw_hashes : [%sig "v5/raw_hashes.mli"] [@@coq_plain_module] - module Compare : [%sig "v5/compare.mli"] + module Compare : [%sig "v5/compare.mli"] [@@coq_plain_module] - module Time : [%sig "v5/time.mli"] + module Time : [%sig "v5/time.mli"] [@@coq_plain_module] - module TzEndian : [%sig "v5/tzEndian.mli"] + module TzEndian : [%sig "v5/tzEndian.mli"] [@@coq_plain_module] - module Bits : [%sig "v5/bits.mli"] + module Bits : [%sig "v5/bits.mli"] [@@coq_plain_module] module Equality_witness : [%sig "v5/equality_witness.mli"] + [@@coq_plain_module] - module FallbackArray : [%sig "v5/fallbackArray.mli"] + module FallbackArray : [%sig "v5/fallbackArray.mli"] [@@coq_plain_module] - module Error_monad : [%sig "v5/error_monad.mli"] + module Error_monad : [%sig "v5/error_monad.mli"] [@@coq_plain_module] open Error_monad - module Seq : [%sig "v5/seq.mli"] + module Seq : [%sig "v5/seq.mli"] [@@coq_plain_module] - module List : [%sig "v5/list.mli"] + module List : [%sig "v5/list.mli"] [@@coq_plain_module] - module Set : [%sig "v5/set.mli"] + module Set : [%sig "v5/set.mli"] [@@coq_plain_module] - module Map : [%sig "v5/map.mli"] + module Map : [%sig "v5/map.mli"] [@@coq_plain_module] - module Option : [%sig "v5/option.mli"] + module Option : [%sig "v5/option.mli"] [@@coq_plain_module] - module Result : [%sig "v5/result.mli"] + module Result : [%sig "v5/result.mli"] [@@coq_plain_module] - module RPC_arg : [%sig "v5/RPC_arg.mli"] + module RPC_arg : [%sig "v5/RPC_arg.mli"] [@@coq_plain_module] - module RPC_path : [%sig "v5/RPC_path.mli"] + module RPC_path : [%sig "v5/RPC_path.mli"] [@@coq_plain_module] - module RPC_query : [%sig "v5/RPC_query.mli"] + module RPC_query : [%sig "v5/RPC_query.mli"] [@@coq_plain_module] - module RPC_service : [%sig "v5/RPC_service.mli"] + module RPC_service : [%sig "v5/RPC_service.mli"] [@@coq_plain_module] - module RPC_answer : [%sig "v5/RPC_answer.mli"] + module RPC_answer : [%sig "v5/RPC_answer.mli"] [@@coq_plain_module] - module RPC_directory : [%sig "v5/RPC_directory.mli"] + module RPC_directory : [%sig "v5/RPC_directory.mli"] [@@coq_plain_module] - module Base58 : [%sig "v5/base58.mli"] + module Base58 : [%sig "v5/base58.mli"] [@@coq_plain_module] - module S : [%sig "v5/s.mli"] + module S : [%sig "v5/s.mli"] [@@coq_plain_module] - module Blake2B : [%sig "v5/blake2B.mli"] + module Blake2B : [%sig "v5/blake2B.mli"] [@@coq_plain_module] - module Bls12_381 : [%sig "v5/bls12_381.mli"] + module Bls12_381 : [%sig "v5/bls12_381.mli"] [@@coq_plain_module] - module Bls_signature : [%sig "v5/bls_signature.mli"] + module Bls_signature : [%sig "v5/bls_signature.mli"] [@@coq_plain_module] - module Ed25519 : [%sig "v5/ed25519.mli"] + module Ed25519 : [%sig "v5/ed25519.mli"] [@@coq_plain_module] - module Secp256k1 : [%sig "v5/secp256k1.mli"] + module Secp256k1 : [%sig "v5/secp256k1.mli"] [@@coq_plain_module] - module P256 : [%sig "v5/p256.mli"] + module P256 : [%sig "v5/p256.mli"] [@@coq_plain_module] - module Chain_id : [%sig "v5/chain_id.mli"] + module Chain_id : [%sig "v5/chain_id.mli"] [@@coq_plain_module] - module Signature : [%sig "v5/signature.mli"] + module Signature : [%sig "v5/signature.mli"] [@@coq_plain_module] - module Block_hash : [%sig "v5/block_hash.mli"] + module Block_hash : [%sig "v5/block_hash.mli"] [@@coq_plain_module] - module Operation_hash : [%sig "v5/operation_hash.mli"] + module Operation_hash : [%sig "v5/operation_hash.mli"] [@@coq_plain_module] module Operation_list_hash : [%sig "v5/operation_list_hash.mli"] + [@@coq_plain_module] module Operation_list_list_hash : [%sig "v5/operation_list_list_hash.mli"] + [@@coq_plain_module] - module Protocol_hash : [%sig "v5/protocol_hash.mli"] + module Protocol_hash : [%sig "v5/protocol_hash.mli"] [@@coq_plain_module] - module Context_hash : [%sig "v5/context_hash.mli"] + module Context_hash : [%sig "v5/context_hash.mli"] [@@coq_plain_module] - module Pvss_secp256k1 : [%sig "v5/pvss_secp256k1.mli"] + module Pvss_secp256k1 : [%sig "v5/pvss_secp256k1.mli"] [@@coq_plain_module] - module Sapling : [%sig "v5/sapling.mli"] + module Sapling : [%sig "v5/sapling.mli"] [@@coq_plain_module] - module Timelock : [%sig "v5/timelock.mli"] + module Timelock : [%sig "v5/timelock.mli"] [@@coq_plain_module] - module Micheline : [%sig "v5/micheline.mli"] + module Micheline : [%sig "v5/micheline.mli"] [@@coq_plain_module] - module Block_header : [%sig "v5/block_header.mli"] + module Block_header : [%sig "v5/block_header.mli"] [@@coq_plain_module] - module Bounded : [%sig "v5/bounded.mli"] + module Bounded : [%sig "v5/bounded.mli"] [@@coq_plain_module] - module Fitness : [%sig "v5/fitness.mli"] + module Fitness : [%sig "v5/fitness.mli"] [@@coq_plain_module] - module Operation : [%sig "v5/operation.mli"] + module Operation : [%sig "v5/operation.mli"] [@@coq_plain_module] - module Context : [%sig "v5/context.mli"] + module Context : [%sig "v5/context.mli"] [@@coq_plain_module] - module Updater : [%sig "v5/updater.mli"] + module Updater : [%sig "v5/updater.mli"] [@@coq_plain_module] - module RPC_context : [%sig "v5/RPC_context.mli"] + module RPC_context : [%sig "v5/RPC_context.mli"] [@@coq_plain_module] end diff --git a/src/lib_protocol_environment/sigs/v5.ml b/src/lib_protocol_environment/sigs/v5.ml index 12ee6b4383ffa..4ec58bd730201 100644 --- a/src/lib_protocol_environment/sigs/v5.ml +++ b/src/lib_protocol_environment/sigs/v5.ml @@ -492,7 +492,7 @@ val ( ^^ ) : *) end # 6 "v5.in.ml" - + [@@coq_plain_module] open Pervasives @@ -574,7 +574,7 @@ val compare : [Left _] values are smaller than [Right _] values. *) end # 10 "v5.in.ml" - + [@@coq_plain_module] module String : sig # 1 "v5/string.mli" @@ -822,7 +822,7 @@ val split_on_char: char -> string -> string list *) end # 12 "v5.in.ml" - + [@@coq_plain_module] module Char : sig # 1 "v5/char.mli" @@ -882,7 +882,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 14 "v5.in.ml" - + [@@coq_plain_module] module Bytes : sig # 1 "v5/bytes.mli" @@ -1146,7 +1146,7 @@ val equal: t -> t -> bool @since 4.03.0 (4.05.0 in BytesLabels) *) end # 16 "v5.in.ml" - + [@@coq_plain_module] module Int32 : sig # 1 "v5/int32.mli" @@ -1297,7 +1297,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 18 "v5.in.ml" - + [@@coq_plain_module] module Int64 : sig # 1 "v5/int64.mli" @@ -1456,7 +1456,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 20 "v5.in.ml" - + [@@coq_plain_module] module Format : sig # 1 "v5/format.mli" @@ -2220,7 +2220,7 @@ val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b *) end # 22 "v5.in.ml" - + [@@coq_plain_module] module Logging : sig # 1 "v5/logging.mli" @@ -2270,7 +2270,7 @@ val log : level -> ('a, Format.formatter, unit, unit) format4 -> 'a val log_string : level -> string -> unit end # 24 "v5.in.ml" - + [@@coq_plain_module] module Hex : sig # 1 "v5/hex.mli" @@ -2358,7 +2358,7 @@ val show : t -> string a string. *) end # 26 "v5.in.ml" - + [@@coq_plain_module] module Z : sig # 1 "v5/z.mli" @@ -2832,7 +2832,7 @@ external of_bits: string -> t = "ml_z_of_bits" *) end # 28 "v5.in.ml" - + [@@coq_plain_module] module Lwt : sig # 1 "v5/lwt.mli" @@ -3103,7 +3103,7 @@ val return_false : bool t {!Lwt.return}[ false]. *) end # 30 "v5.in.ml" - + [@@coq_plain_module] module Data_encoding : sig # 1 "v5/data_encoding.mli" @@ -3575,6 +3575,8 @@ type 't case type case_tag = Tag of int | Json_only +type match_result + (** A sum descriptor can be optimized by providing a specific [matching_function] which efficiently determines in which case some value of type ['a] falls. @@ -3590,8 +3592,6 @@ type case_tag = Tag of int | Json_only inhabited. *) type 'a matching_function = 'a -> match_result -and match_result - (** [matched t e u] represents the fact that a value is tagged with [t] and carries the payload [u] which can be encoded with [e]. @@ -4592,7 +4592,7 @@ module Binary : sig end end # 32 "v5.in.ml" - + [@@coq_plain_module] module Raw_hashes : sig # 1 "v5/raw_hashes.mli" @@ -4634,7 +4634,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end # 34 "v5.in.ml" - + [@@coq_plain_module] module Compare : sig # 1 "v5/compare.mli" @@ -4760,6 +4760,7 @@ module Int : sig external equal : int -> int -> bool = "%equal" end +[@@coq_plain_module] module Int32 : S with type t = int32 @@ -4912,7 +4913,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = val or_else : int -> (unit -> int) -> int end # 36 "v5.in.ml" - + [@@coq_plain_module] module Time : sig # 1 "v5/time.mli" @@ -4966,7 +4967,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end # 38 "v5.in.ml" - + [@@coq_plain_module] module TzEndian : sig # 1 "v5/tzEndian.mli" @@ -5032,7 +5033,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end # 40 "v5.in.ml" - + [@@coq_plain_module] module Bits : sig # 1 "v5/bits.mli" @@ -5069,7 +5070,7 @@ end val numbits : int -> int end # 42 "v5.in.ml" - + [@@coq_plain_module] module Equality_witness : sig # 1 "v5/equality_witness.mli" @@ -5138,6 +5139,7 @@ val hash : 'a t -> int end # 44 "v5.in.ml" + [@@coq_plain_module] module FallbackArray : sig # 1 "v5/fallbackArray.mli" @@ -5226,8 +5228,8 @@ val fold : ('b -> 'a -> 'b) -> 'a t -> 'b -> 'b filled. *) val fold_map : ('b -> 'a -> 'b * 'c) -> 'a t -> 'b -> 'c -> 'b * 'c t end -# 46 "v5.in.ml" - +# 47 "v5.in.ml" + [@@coq_plain_module] module Error_monad : sig # 1 "v5/error_monad.mli" @@ -5656,8 +5658,8 @@ module Lwt_tzresult_syntax : sig ('a * 'b, 'error trace) result Lwt.t end end -# 48 "v5.in.ml" - +# 49 "v5.in.ml" + [@@coq_plain_module] open Error_monad @@ -5783,8 +5785,8 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 52 "v5.in.ml" - +# 53 "v5.in.ml" + [@@coq_plain_module] module List : sig # 1 "v5/list.mli" @@ -7115,8 +7117,8 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 54 "v5.in.ml" - +# 55 "v5.in.ml" + [@@coq_plain_module] module Set : sig # 1 "v5/set.mli" @@ -7264,8 +7266,8 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 56 "v5.in.ml" - +# 57 "v5.in.ml" + [@@coq_plain_module] module Map : sig # 1 "v5/map.mli" @@ -7425,16 +7427,16 @@ module type S = sig val of_seq : (key * 'a) Seq.t -> 'a t val iter_ep : - (key -> 'a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + (key -> 'a -> (unit, 'error list) result Lwt.t) -> 'a t -> - (unit, 'error Error_monad.trace) result Lwt.t + (unit, 'error list) result Lwt.t end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 58 "v5.in.ml" - +# 59 "v5.in.ml" + [@@coq_plain_module] module Option : sig # 1 "v5/option.mli" @@ -7581,8 +7583,8 @@ val catch : ?catch_only:(exn -> bool) -> (unit -> 'a) -> 'a option val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> 'a option Lwt.t end -# 60 "v5.in.ml" - +# 61 "v5.in.ml" + [@@coq_plain_module] module Result : sig # 1 "v5/result.mli" @@ -7747,8 +7749,8 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 62 "v5.in.ml" - +# 63 "v5.in.ml" + [@@coq_plain_module] module RPC_arg : sig # 1 "v5/RPC_arg.mli" @@ -7817,8 +7819,8 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 64 "v5.in.ml" - +# 65 "v5.in.ml" + [@@coq_plain_module] module RPC_path : sig # 1 "v5/RPC_path.mli" @@ -7873,8 +7875,8 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 66 "v5.in.ml" - +# 67 "v5.in.ml" + [@@coq_plain_module] module RPC_query : sig # 1 "v5/RPC_query.mli" @@ -7945,8 +7947,8 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 68 "v5.in.ml" - +# 69 "v5.in.ml" + [@@coq_plain_module] module RPC_service : sig # 1 "v5/RPC_service.mli" @@ -8022,8 +8024,8 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 70 "v5.in.ml" - +# 71 "v5.in.ml" + [@@coq_plain_module] module RPC_answer : sig # 1 "v5/RPC_answer.mli" @@ -8083,8 +8085,8 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 72 "v5.in.ml" - +# 73 "v5.in.ml" + [@@coq_plain_module] module RPC_directory : sig # 1 "v5/RPC_directory.mli" @@ -8348,8 +8350,8 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 74 "v5.in.ml" - +# 75 "v5.in.ml" + [@@coq_plain_module] module Base58 : sig # 1 "v5/base58.mli" @@ -8413,8 +8415,8 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 76 "v5.in.ml" - +# 77 "v5.in.ml" + [@@coq_plain_module] module S : sig # 1 "v5/s.mli" @@ -8831,8 +8833,8 @@ module type PVSS = sig val reconstruct : Clear_share.t list -> int list -> Public_key.t end end -# 78 "v5.in.ml" - +# 79 "v5.in.ml" + [@@coq_plain_module] module Blake2B : sig # 1 "v5/blake2B.mli" @@ -8896,8 +8898,8 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 80 "v5.in.ml" - +# 81 "v5.in.ml" + [@@coq_plain_module] module Bls12_381 : sig # 1 "v5/bls12_381.mli" @@ -8934,8 +8936,8 @@ module G2 : S.CURVE with type Scalar.t = Fr.t val pairing_check : (G1.t * G2.t) list -> bool end -# 82 "v5.in.ml" - +# 83 "v5.in.ml" + [@@coq_plain_module] module Bls_signature : sig # 1 "v5/bls_signature.mli" @@ -9030,8 +9032,8 @@ val verify : pk -> Bytes.t -> signature -> bool val aggregate_verify : (pk * Bytes.t) list -> signature -> bool end -# 84 "v5.in.ml" - +# 85 "v5.in.ml" + [@@coq_plain_module] module Ed25519 : sig # 1 "v5/ed25519.mli" @@ -9064,8 +9066,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 86 "v5.in.ml" - +# 87 "v5.in.ml" + [@@coq_plain_module] module Secp256k1 : sig # 1 "v5/secp256k1.mli" @@ -9098,8 +9100,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v5.in.ml" - +# 89 "v5.in.ml" + [@@coq_plain_module] module P256 : sig # 1 "v5/p256.mli" @@ -9132,8 +9134,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v5.in.ml" - +# 91 "v5.in.ml" + [@@coq_plain_module] module Chain_id : sig # 1 "v5/chain_id.mli" @@ -9164,8 +9166,8 @@ end include S.HASH end -# 92 "v5.in.ml" - +# 93 "v5.in.ml" + [@@coq_plain_module] module Signature : sig # 1 "v5/signature.mli" @@ -9216,8 +9218,8 @@ include and type Public_key.t = public_key and type watermark := watermark end -# 94 "v5.in.ml" - +# 95 "v5.in.ml" + [@@coq_plain_module] module Block_hash : sig # 1 "v5/block_hash.mli" @@ -9249,8 +9251,8 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 96 "v5.in.ml" - +# 97 "v5.in.ml" + [@@coq_plain_module] module Operation_hash : sig # 1 "v5/operation_hash.mli" @@ -9282,8 +9284,8 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 98 "v5.in.ml" - +# 99 "v5.in.ml" + [@@coq_plain_module] module Operation_list_hash : sig # 1 "v5/operation_list_hash.mli" @@ -9315,8 +9317,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 100 "v5.in.ml" +# 101 "v5.in.ml" + [@@coq_plain_module] module Operation_list_list_hash : sig # 1 "v5/operation_list_list_hash.mli" @@ -9348,8 +9351,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 102 "v5.in.ml" +# 104 "v5.in.ml" + [@@coq_plain_module] module Protocol_hash : sig # 1 "v5/protocol_hash.mli" @@ -9381,8 +9385,8 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 104 "v5.in.ml" - +# 107 "v5.in.ml" + [@@coq_plain_module] module Context_hash : sig # 1 "v5/context_hash.mli" @@ -9434,8 +9438,8 @@ end type version = Version.t end -# 106 "v5.in.ml" - +# 109 "v5.in.ml" + [@@coq_plain_module] module Pvss_secp256k1 : sig # 1 "v5/pvss_secp256k1.mli" @@ -9468,8 +9472,8 @@ end include S.PVSS end -# 108 "v5.in.ml" - +# 111 "v5.in.ml" + [@@coq_plain_module] module Sapling : sig # 1 "v5/sapling.mli" @@ -9616,8 +9620,8 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v5.in.ml" - +# 113 "v5.in.ml" + [@@coq_plain_module] module Timelock : sig # 1 "v5/timelock.mli" @@ -9675,8 +9679,8 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v5.in.ml" - +# 115 "v5.in.ml" + [@@coq_plain_module] module Micheline : sig # 1 "v5/micheline.mli" @@ -9735,8 +9739,8 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 114 "v5.in.ml" - +# 117 "v5.in.ml" + [@@coq_plain_module] module Block_header : sig # 1 "v5/block_header.mli" @@ -9792,8 +9796,8 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 116 "v5.in.ml" - +# 119 "v5.in.ml" + [@@coq_plain_module] module Bounded : sig # 1 "v5/bounded.mli" @@ -9865,11 +9869,11 @@ module Int32 : sig allow future compatiblity with larger bounds, at the price of addding 1-3 redundant bytes to each message. *) - module Make (_ : BOUNDS) : S + module Make (B : BOUNDS) : S end end -# 118 "v5.in.ml" - +# 121 "v5.in.ml" + [@@coq_plain_module] module Fitness : sig # 1 "v5/fitness.mli" @@ -9902,8 +9906,8 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 120 "v5.in.ml" - +# 123 "v5.in.ml" + [@@coq_plain_module] module Operation : sig # 1 "v5/operation.mli" @@ -9946,8 +9950,8 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 122 "v5.in.ml" - +# 125 "v5.in.ml" + [@@coq_plain_module] module Context : sig # 1 "v5/context.mli" @@ -10092,6 +10096,7 @@ end module Kind : sig type t = [`Value | `Tree] end +[@@coq_plain_module] module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the @@ -10583,8 +10588,8 @@ module Cache : and type key = cache_key and type value = cache_value end -# 124 "v5.in.ml" - +# 127 "v5.in.ml" + [@@coq_plain_module] module Updater : sig # 1 "v5/updater.mli" @@ -10884,8 +10889,8 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 126 "v5.in.ml" - +# 129 "v5.in.ml" + [@@coq_plain_module] module RPC_context : sig # 1 "v5/RPC_context.mli" @@ -11039,6 +11044,6 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 128 "v5.in.ml" - +# 131 "v5.in.ml" + [@@coq_plain_module] end diff --git a/src/lib_protocol_environment/sigs/v5/bounded.mli b/src/lib_protocol_environment/sigs/v5/bounded.mli index 46539808d0884..f2a037d48a7b1 100644 --- a/src/lib_protocol_environment/sigs/v5/bounded.mli +++ b/src/lib_protocol_environment/sigs/v5/bounded.mli @@ -66,5 +66,5 @@ module Int32 : sig allow future compatiblity with larger bounds, at the price of addding 1-3 redundant bytes to each message. *) - module Make (_ : BOUNDS) : S + module Make (B : BOUNDS) : S end diff --git a/src/lib_protocol_environment/sigs/v5/compare.mli b/src/lib_protocol_environment/sigs/v5/compare.mli index 0437dd1e23de5..38f5f19e98bd3 100644 --- a/src/lib_protocol_environment/sigs/v5/compare.mli +++ b/src/lib_protocol_environment/sigs/v5/compare.mli @@ -120,6 +120,7 @@ module Int : sig external equal : int -> int -> bool = "%equal" end +[@@coq_plain_module] module Int32 : S with type t = int32 diff --git a/src/lib_protocol_environment/sigs/v5/context.mli b/src/lib_protocol_environment/sigs/v5/context.mli index 4d7ccd466b731..068eedd5add5f 100644 --- a/src/lib_protocol_environment/sigs/v5/context.mli +++ b/src/lib_protocol_environment/sigs/v5/context.mli @@ -139,6 +139,7 @@ end module Kind : sig type t = [`Value | `Tree] end +[@@coq_plain_module] module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the diff --git a/src/lib_protocol_environment/sigs/v5/data_encoding.mli b/src/lib_protocol_environment/sigs/v5/data_encoding.mli index e7cd699b0623a..b3c52a30caf2c 100644 --- a/src/lib_protocol_environment/sigs/v5/data_encoding.mli +++ b/src/lib_protocol_environment/sigs/v5/data_encoding.mli @@ -466,6 +466,8 @@ type 't case type case_tag = Tag of int | Json_only +type match_result + (** A sum descriptor can be optimized by providing a specific [matching_function] which efficiently determines in which case some value of type ['a] falls. @@ -481,8 +483,6 @@ type case_tag = Tag of int | Json_only inhabited. *) type 'a matching_function = 'a -> match_result -and match_result - (** [matched t e u] represents the fact that a value is tagged with [t] and carries the payload [u] which can be encoded with [e]. diff --git a/src/lib_protocol_environment/sigs/v5/map.mli b/src/lib_protocol_environment/sigs/v5/map.mli index 559bf1cf78546..8e1d02424fa2a 100644 --- a/src/lib_protocol_environment/sigs/v5/map.mli +++ b/src/lib_protocol_environment/sigs/v5/map.mli @@ -154,9 +154,9 @@ module type S = sig val of_seq : (key * 'a) Seq.t -> 'a t val iter_ep : - (key -> 'a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + (key -> 'a -> (unit, 'error list) result Lwt.t) -> 'a t -> - (unit, 'error Error_monad.trace) result Lwt.t + (unit, 'error list) result Lwt.t end diff --git a/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml b/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml index 412f4825b50b0..97c3f9809d1fb 100644 --- a/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml +++ b/src/proto_013_PtJakart/lib_protocol/script_interpreter.ml @@ -1273,7 +1273,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (return_none [@ocaml.tailcall]) ctxt | Ok (Eq, Eq) -> ( let kkinfo = kinfo_of_kinstr k in - match kkinfo.kstack_ty with + match[@coq_match_with_default] kkinfo.kstack_ty with | Item_t (_, s) -> let kstack_ty = Item_t (output_ty, s) in let kkinfo = {kkinfo with kstack_ty} in -- GitLab From 60abbbed0319fc367155d49206f94baac869aa7a Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 24 Aug 2022 17:55:23 +0200 Subject: [PATCH 3/3] Proto: add coq-of-ocaml changes for proto K --- .../client_baking_denunciation.ml | 6 +- .../lib_injector/injector_functor.ml | 2 +- src/proto_014_PtKathma/lib_plugin/RPC.ml | 17 +- .../lib_protocol/alpha_context.ml | 3 +- .../lib_protocol/alpha_context.mli | 154 +- src/proto_014_PtKathma/lib_protocol/apply.ml | 130 +- .../lib_protocol/apply_results.ml | 402 +++--- .../lib_protocol/apply_results.mli | 3 +- src/proto_014_PtKathma/lib_protocol/baking.ml | 2 +- .../lib_protocol/blinded_public_key_hash.ml | 14 +- .../lib_protocol/bond_id_repr.ml | 2 +- .../lib_protocol/bootstrap_storage.ml | 11 +- .../lib_protocol/cache_repr.ml | 20 +- .../lib_protocol/carbonated_map.ml | 11 +- .../lib_protocol/carbonated_map.mli | 16 +- .../lib_protocol/cycle_repr.ml | 3 +- .../lib_protocol/delegate_storage.ml | 48 +- .../lib_protocol/dependent_bool.ml | 4 +- .../lib_protocol/dependent_bool.mli | 2 +- .../lib_protocol/fees_storage.ml | 6 +- .../lib_protocol/fitness_repr.ml | 8 +- .../lib_protocol/gas_comparable_input_size.ml | 2 +- .../lib_protocol/gas_input_size.ml | 2 +- .../lib_protocol/gas_monad.ml | 4 +- .../lib_protocol/global_constants_storage.ml | 2 +- .../lib_protocol/indexable.ml | 75 +- .../lib_protocol/indexable.mli | 16 +- .../lib_protocol/init_storage.ml | 8 +- .../lib_protocol/level_repr.ml | 3 +- .../lib_protocol/level_storage.ml | 4 +- .../liquidity_baking_migration.ml | 8 +- .../lib_protocol/merkle_list.ml | 57 +- .../lib_protocol/merkle_list.mli | 7 +- .../lib_protocol/michelson_v1_gas.ml | 62 +- .../lib_protocol/michelson_v1_primitives.ml | 16 +- src/proto_014_PtKathma/lib_protocol/misc.ml | 6 +- .../lib_protocol/operation_repr.ml | 223 +-- .../lib_protocol/operation_repr.mli | 23 +- .../lib_protocol/period_repr.ml | 4 +- .../lib_protocol/raw_context.ml | 74 +- .../lib_protocol/raw_context.mli | 2 + .../lib_protocol/raw_context_intf.ml | 214 +-- .../lib_protocol/raw_level_repr.ml | 4 +- .../lib_protocol/round_repr.ml | 6 +- .../lib_protocol/sampler.ml | 2 +- .../lib_protocol/sapling_repr.ml | 2 + .../lib_protocol/sapling_storage.ml | 4 +- .../lib_protocol/sc_rollup_arith.ml | 74 +- .../lib_protocol/sc_rollup_errors.ml | 2 +- .../lib_protocol/sc_rollup_game_repr.ml | 10 +- .../lib_protocol/sc_rollup_inbox_repr.ml | 36 +- .../lib_protocol/sc_rollup_inbox_repr.mli | 2 + .../sc_rollup_management_protocol.ml | 67 +- .../lib_protocol/sc_rollup_operations.ml | 2 +- .../lib_protocol/sc_rollup_proof_repr.ml | 18 +- .../sc_rollup_refutation_storage.ml | 4 +- .../lib_protocol/sc_rollup_repr.ml | 6 +- .../lib_protocol/sc_rollup_repr.mli | 2 +- .../lib_protocol/sc_rollup_stake_storage.ml | 18 +- .../lib_protocol/sc_rollup_storage.ml | 5 +- .../lib_protocol/sc_rollup_storage.mli | 2 +- .../lib_protocol/sc_rollup_tick_repr.ml | 26 +- .../lib_protocol/sc_rollup_wasm.ml | 26 +- .../lib_protocol/sc_rollups.ml | 30 +- .../lib_protocol/sc_rollups.mli | 2 +- .../lib_protocol/script_big_map.ml | 64 +- .../lib_protocol/script_comparable.ml | 84 +- .../lib_protocol/script_int.ml | 2 +- .../lib_protocol/script_int.mli | 2 +- .../lib_protocol/script_interpreter.ml | 826 ++++++----- .../lib_protocol/script_interpreter_defs.ml | 452 +++--- .../lib_protocol/script_ir_annot.ml | 2 +- .../lib_protocol/script_ir_translator.ml | 1241 +++++++++-------- .../lib_protocol/script_ir_translator.mli | 2 + .../lib_protocol/script_map.ml | 28 +- .../lib_protocol/script_repr.ml | 14 +- .../lib_protocol/script_set.ml | 16 +- .../lib_protocol/script_string.ml | 2 +- .../lib_protocol/script_tc_errors.ml | 4 +- .../lib_protocol/script_typed_ir.ml | 120 +- .../lib_protocol/script_typed_ir.mli | 11 +- .../lib_protocol/script_typed_ir_size.ml | 126 +- .../lib_protocol/seed_repr.ml | 6 +- .../lib_protocol/services_registration.ml | 20 +- .../lib_protocol/services_registration.mli | 6 +- .../lib_protocol/skip_list_repr.ml | 18 +- .../lib_protocol/skip_list_repr.mli | 6 +- .../lib_protocol/slot_repr.ml | 6 +- .../lib_protocol/storage.ml | 83 +- .../lib_protocol/storage_description.ml | 18 +- .../lib_protocol/storage_functors.ml | 19 +- .../lib_protocol/ticket_accounting.ml | 16 +- .../lib_protocol/ticket_hash_builder.ml | 10 +- .../lib_protocol/ticket_hash_repr.ml | 29 +- .../lib_protocol/ticket_lazy_storage_diff.ml | 27 +- .../lib_protocol/ticket_scanner.ml | 49 +- .../lib_protocol/ticket_scanner.mli | 2 +- src/proto_014_PtKathma/lib_protocol/token.ml | 151 +- src/proto_014_PtKathma/lib_protocol/token.mli | 60 +- .../lib_protocol/tx_rollup_commitment_repr.ml | 8 +- .../tx_rollup_commitment_repr.mli | 2 +- .../tx_rollup_commitment_storage.ml | 30 +- .../tx_rollup_commitment_storage.mli | 7 +- .../lib_protocol/tx_rollup_errors_repr.ml | 28 +- .../lib_protocol/tx_rollup_gas.ml | 2 +- .../lib_protocol/tx_rollup_l2_apply.ml | 131 +- .../lib_protocol/tx_rollup_l2_apply.mli | 143 +- .../lib_protocol/tx_rollup_l2_batch.ml | 24 +- .../lib_protocol/tx_rollup_l2_batch.mli | 16 +- .../lib_protocol/tx_rollup_l2_context.ml | 30 +- .../lib_protocol/tx_rollup_l2_context_sig.ml | 300 ++-- .../lib_protocol/tx_rollup_l2_storage_sig.ml | 62 +- .../lib_protocol/tx_rollup_l2_verifier.ml | 15 +- .../lib_protocol/tx_rollup_message_repr.ml | 2 +- .../lib_protocol/tx_rollup_parameters.ml | 6 +- .../lib_protocol/tx_rollup_state_repr.ml | 2 +- .../lib_protocol/tx_rollup_ticket.ml | 8 +- .../lib_protocol/validate_operation.ml | 8 +- 118 files changed, 3592 insertions(+), 2780 deletions(-) diff --git a/src/proto_014_PtKathma/lib_delegate/client_baking_denunciation.ml b/src/proto_014_PtKathma/lib_delegate/client_baking_denunciation.ml index 4f36381313075..c4a652dc42e5b 100644 --- a/src/proto_014_PtKathma/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_014_PtKathma/lib_delegate/client_baking_denunciation.ml @@ -114,7 +114,7 @@ let get_block_offset level = Events.(emit invalid_level_conversion) (Environment.wrap_tztrace errs) >>= fun () -> Lwt.return (`Head 0) -let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) +let get_payload_hash (type kind) (op_kind : kind Consensus_operation_type.t) (op : kind Operation.t) = match (op_kind, op.protocol_data.contents) with | Preendorsement, Single (Preendorsement consensus_content) @@ -123,7 +123,7 @@ let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) | _ -> . let double_consensus_op_evidence (type kind) : - kind consensus_operation_type -> + kind Consensus_operation_type.t -> #Protocol_client_context.full -> 'a -> branch:Block_hash.t -> @@ -135,7 +135,7 @@ let double_consensus_op_evidence (type kind) : | Preendorsement -> Plugin.RPC.Forge.double_preendorsement_evidence let process_consensus_op (type kind) cctxt - (op_kind : kind consensus_operation_type) (new_op : kind Operation.t) + (op_kind : kind Consensus_operation_type.t) (new_op : kind Operation.t) chain_id level round slot ops_table = let map = Option.value ~default:Slot_Map.empty diff --git a/src/proto_014_PtKathma/lib_injector/injector_functor.ml b/src/proto_014_PtKathma/lib_injector/injector_functor.ml index 0792b7f73634e..8c4efa61bd75e 100644 --- a/src/proto_014_PtKathma/lib_injector/injector_functor.ml +++ b/src/proto_014_PtKathma/lib_injector/injector_functor.ml @@ -541,7 +541,7 @@ module Make (Rollup : PARAMETERS) = struct let* packed_op, result = simulate_operations ~must_succeed state operations in - let results = Apply_results.to_list result in + let results = Apply_results.packed_contents_result_list_to_list result in let failure = ref false in let* rev_non_failing_operations = List.fold_left2_s diff --git a/src/proto_014_PtKathma/lib_plugin/RPC.ml b/src/proto_014_PtKathma/lib_plugin/RPC.ml index 3cd04ae080349..6ee1eaacd57ee 100644 --- a/src/proto_014_PtKathma/lib_plugin/RPC.ml +++ b/src/proto_014_PtKathma/lib_plugin/RPC.ml @@ -50,7 +50,7 @@ module Registration = struct let register0_fullctxt ~chunked s f = patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = @@ -60,7 +60,8 @@ module Registration = struct patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> let mode = - if q#successor_level then `Successor_level else `Head_level + if q#successor_level then Services_registration.Successor_level + else Head_level in Services_registration.rpc_init ctxt mode >>=? fun ctxt -> f ctxt q i) @@ -75,7 +76,7 @@ module Registration = struct let opt_register0_fullctxt ~chunked s f = patched_services := RPC_directory.opt_register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = @@ -88,7 +89,7 @@ module Registration = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let opt_register1_fullctxt ~chunked s f = @@ -98,7 +99,7 @@ module Registration = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = @@ -114,7 +115,7 @@ module Registration = struct !patched_services s (fun ((ctxt, arg1), arg2) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = @@ -927,8 +928,8 @@ module Scripts = struct Token.transfer ~origin:Simulation ctxt - `Minted - (`Contract dummy_contract) + (Source_infinite Minted) + (Sink_container (Contract dummy_contract)) balance >>=? fun (ctxt, _) -> return (ctxt, dummy_contract_hash) in diff --git a/src/proto_014_PtKathma/lib_protocol/alpha_context.ml b/src/proto_014_PtKathma/lib_protocol/alpha_context.ml index 2a9009095c67c..22335eda85554 100644 --- a/src/proto_014_PtKathma/lib_protocol/alpha_context.ml +++ b/src/proto_014_PtKathma/lib_protocol/alpha_context.ml @@ -80,7 +80,7 @@ module Sc_rollup = struct include Sc_rollups module Outbox = struct - include Sc_rollup_storage.Outbox + include Sc_rollup_storage.Outbox_aux module Message = Sc_rollup_outbox_message_repr end @@ -164,7 +164,6 @@ end module Round = struct include Round_repr - module Durations = Durations type round_durations = Durations.t diff --git a/src/proto_014_PtKathma/lib_protocol/alpha_context.mli b/src/proto_014_PtKathma/lib_protocol/alpha_context.mli index 6cb97c19b8488..b9cdd9aac18a3 100644 --- a/src/proto_014_PtKathma/lib_protocol/alpha_context.mli +++ b/src/proto_014_PtKathma/lib_protocol/alpha_context.mli @@ -103,9 +103,9 @@ end (** This module re-exports definitions from {!Tez_repr}. *) module Tez : sig - type repr + type repr = Tez_repr.repr - type t = Tez_tag of repr [@@ocaml.unboxed] + type t = Tez_repr.t = Tez_tag of repr [@@ocaml.unboxed] include BASIC_DATA with type t := t @@ -1378,7 +1378,7 @@ module Big_map : sig Id.t -> (context * Script.expr list) tzresult Lwt.t - type update = { + type update = Lazy_storage_kind.Big_map.update = { key : Script_repr.expr; key_hash : Script_expr_hash.t; value : Script_repr.expr option; @@ -1386,7 +1386,10 @@ module Big_map : sig type updates = update list - type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr} + type alloc = Lazy_storage_kind.Big_map.alloc = { + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } end (** This module re-exports definitions from {!Sapling_repr}, {!Sapling_storage} @@ -1416,7 +1419,7 @@ module Sapling : sig val diff_encoding : diff Data_encoding.t module Memo_size : sig - type t + type t = Sapling_repr.Memo_size.t val encoding : t Data_encoding.t @@ -1471,7 +1474,7 @@ module Sapling : sig string -> (context * (Int64.t * state) option) tzresult Lwt.t - type alloc = {memo_size : Memo_size.t} + type alloc = Lazy_storage_kind.Sapling_state.alloc = {memo_size : Memo_size.t} type updates = diff @@ -1571,7 +1574,7 @@ end (** This module re-exports definitions from {!Ticket_hash_repr}. *) module Ticket_hash : sig - type t + type t = Ticket_hash_repr.t val encoding : t Data_encoding.t @@ -1618,7 +1621,7 @@ end (** This module re-exports definitions from {!Contract_repr} and {!Contract_storage}. *) module Contract : sig - type t = + type t = Contract_repr.t = | Implicit of Signature.Public_key_hash.t | Originated of Contract_hash.t @@ -1782,7 +1785,7 @@ end (** This module re-exports definitions from {!Tx_rollup_repr} and {!Tx_rollup_storage}. *) module Tx_rollup : sig - include BASIC_DATA + include BASIC_DATA with type t = Tx_rollup_repr.t val rpc_arg : t RPC_arg.arg @@ -1822,11 +1825,12 @@ module Tx_rollup_withdraw : sig val encoding : t Data_encoding.t end +[@@coq_plain_module] (** This module re-exports definitions from {!Tx_rollup_withdraw_list_hash_repr}. *) module Tx_rollup_withdraw_list_hash : sig - include S.HASH + include S.HASH with type t = Tx_rollup_withdraw_list_hash_repr.t val hash_uncarbonated : Tx_rollup_withdraw.t list -> t @@ -1972,7 +1976,7 @@ end (** This module re-exports definitions from {!Tx_rollup_message_repr}. *) module Tx_rollup_message : sig - type deposit = { + type deposit = Tx_rollup_message_repr.deposit = { sender : public_key_hash; destination : Tx_rollup_l2_address.Indexable.value; ticket_hash : Ticket_hash.t; @@ -2120,11 +2124,14 @@ module Tx_rollup_commitment : sig val compact : t -> Compact.t end + type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : context -> Compact.t -> - [ `Hash of Tx_rollup_message_result_hash.t - | `Result of Tx_rollup_message_result.t ] -> + hash_or_result -> path:Merkle.path -> index:int -> context tzresult @@ -2235,6 +2242,12 @@ end (** This module re-exports definitions from {!Tx_rollup_errors_repr}. *) module Tx_rollup_errors : sig + type error_or_commitment = Inbox | Commitment + + type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment.Merkle.h * int + | Hash of Tx_rollup_message_result_hash.t + type error += | Tx_rollup_already_exists of Tx_rollup.t | Tx_rollup_does_not_exist of Tx_rollup.t @@ -2272,7 +2285,7 @@ module Tx_rollup_errors : sig length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -2291,9 +2304,7 @@ module Tx_rollup_errors : sig } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash.t; - expected : - [ `Valid_path of Tx_rollup_commitment.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash.t ]; + expected : valid_path_or_hash; } | Wrong_deposit_parameters | Proof_failed_to_reject @@ -2305,7 +2316,7 @@ module Tx_rollup_errors : sig | No_withdrawals_to_dispatch val check_path_depth : - [`Inbox | `Commitment] -> int -> count_limit:int -> unit tzresult + error_or_commitment -> int -> count_limit:int -> unit tzresult end (** This is a forward declaration to avoid circular dependencies. @@ -2313,14 +2324,14 @@ end TODO : find a better way to resolve the circular dependency https://gitlab.com/tezos/tezos/-/issues/3147 *) module Sc_rollup_repr : sig - module Address : S.HASH + module Address : S.HASH with type t = Sc_rollup_repr.t type t = Address.t end (** This module re-exports definitions from {!Bond_id_repr}. *) module Bond_id : sig - type t = + type t = Bond_id_repr.t = | Tx_rollup_bond_id of Tx_rollup.t | Sc_rollup_bond_id of Sc_rollup_repr.t @@ -2474,7 +2485,10 @@ module Delegate : sig endorsing_power:int -> context tzresult Lwt.t - type deposits = {initial_amount : Tez.t; current_amount : Tez.t} + type deposits = Storage.deposits = { + initial_amount : Tez.t; + current_amount : Tez.t; + } val frozen_deposits : context -> public_key_hash -> deposits tzresult Lwt.t @@ -2739,7 +2753,7 @@ module Sc_rollup : sig module Map : Map.S with type key = t end - module Address = Sc_rollup_repr.Address + module Address = Sc_rollup_repr.Address [@@coq_plain_module] type t = Sc_rollup_repr.t @@ -2882,6 +2896,7 @@ module Sc_rollup : sig val all_names : string list end + [@@coq_plain_module] module ArithPVM : sig module type P = sig @@ -2979,7 +2994,7 @@ module Sc_rollup : sig module Number_of_ticks : Bounded.Int32.S module Commitment : sig - module Hash : S.HASH + module Hash : S.HASH [@@coq_plain_module] type t = { compressed_state : State_hash.t; @@ -3119,6 +3134,8 @@ module Sc_rollup : sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end module MakeHashingScheme (Tree : TREE) : @@ -3149,7 +3166,7 @@ module Sc_rollup : sig module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end type wrapped_proof = @@ -3581,12 +3598,13 @@ end (** All the definitions below are re-exported from {!Operation_repr}. *) -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot.t; @@ -3850,10 +3868,14 @@ module Operation : sig type nonrec packed_protocol_data = packed_protocol_data - type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t + module Consensus_watermark : sig + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t + end + + open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark @@ -4286,35 +4308,39 @@ end (** This module re-exports definitions from {!Token}. *) module Token : sig type container = - [ `Contract of Contract.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract.t * Bond_id.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t + + type infinite_source = + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards type source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards - | container ] - - type sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Burned - | `Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments - | container ] + | Source_infinite of infinite_source + | Source_container of container + + type infinite_sink = + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments + | Burned + + type sink = Sink_infinite of infinite_sink | Sink_container of container val allocated : context -> container -> (context * bool) tzresult Lwt.t @@ -4323,15 +4349,15 @@ module Token : sig val transfer_n : ?origin:Receipt.update_origin -> context -> - ([< source] * Tez.t) list -> - [< sink] -> + (source * Tez.t) list -> + sink -> (context * Receipt.balance_updates) tzresult Lwt.t val transfer : ?origin:Receipt.update_origin -> context -> - [< source] -> - [< sink] -> + source -> + sink -> Tez.t -> (context * Receipt.balance_updates) tzresult Lwt.t end diff --git a/src/proto_014_PtKathma/lib_protocol/apply.ml b/src/proto_014_PtKathma/lib_protocol/apply.ml index aae6b682ad14b..9bd7192e78b99 100644 --- a/src/proto_014_PtKathma/lib_protocol/apply.ml +++ b/src/proto_014_PtKathma/lib_protocol/apply.ml @@ -794,7 +794,11 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter (* If the implicit contract is not yet allocated at this point then the next transfer of tokens will allocate it. *) Contract.allocated ctxt contract >>= fun already_allocated -> - Token.transfer ctxt (`Contract source) (`Contract contract) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> let is_unit = match parameter with @@ -838,7 +842,11 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount does not exist, [Script_cache.find] will signal that by returning [None] and we'll fail. *) - Token.transfer ctxt (`Contract source) (`Contract contract) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt contract_hash >>=? fun (ctxt, cache_key, script) -> match script with @@ -993,7 +1001,11 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer in Tx_rollup_state.get ctxt dst_rollup >>=? fun (ctxt, state) -> Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost -> - Token.transfer ctxt (`Contract (Contract.Implicit payer)) `Burned cost + Token.transfer + ctxt + (Source_container (Contract (Contract.Implicit payer))) + (Sink_infinite Burned) + cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_inbox.append_message ctxt dst_rollup state deposit >>=? fun (ctxt, state, paid_storage_size_diff) -> @@ -1048,7 +1060,11 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code | None -> return ctxt | Some delegate -> Delegate.init ctxt contract delegate) >>=? fun ctxt -> - Token.transfer ctxt (`Contract source) (`Contract contract) credit + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + credit >>=? fun (ctxt, balance_updates) -> Fees.record_paid_storage_space ctxt contract >|=? fun (ctxt, size, paid_storage_size_diff) -> @@ -1220,7 +1236,7 @@ let apply_internal_manager_operation_content : >|=? fun (ctxt, consumed_gas, ops) -> (ctxt, IDelegation_result {consumed_gas}, ops) -let apply_external_manager_operation_content : +let[@coq_axiom_with_reason "unresolved implicit type"] apply_external_manager_operation_content : type kind. context -> Script_ir_translator.unparsing_mode -> @@ -1364,7 +1380,7 @@ let apply_external_manager_operation_content : Tx_rollup_commitment.check_message_result ctxt commitment.commitment - (`Result {context_hash; withdraw_list_hash}) + (Result {context_hash; withdraw_list_hash}) ~path:message_result_path ~index:message_index >>?= fun ctxt -> @@ -1556,7 +1572,7 @@ let apply_external_manager_operation_content : let contract = Contract.Originated destination in Contract.increase_paid_storage ctxt contract ~amount_in_bytes >>=? fun ctxt -> - let payer = `Contract (Contract.Implicit source) in + let payer = Token.Source_container (Contract (Contract.Implicit source)) in Fees.burn_storage_increase_fees ctxt ~payer amount_in_bytes >|=? fun (ctxt, storage_bus) -> let result = @@ -1587,7 +1603,11 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, state, paid_storage_size_diff) -> Tx_rollup_state.burn_cost ~limit:burn_limit state message_size >>?= fun cost -> - Token.transfer ctxt (`Contract source_contract) `Burned cost + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_infinite Burned) + cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt -> let result = @@ -1607,8 +1627,8 @@ let apply_external_manager_operation_content : let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in Token.transfer ctxt - (`Contract source_contract) - (`Frozen_bonds (source_contract, bond_id)) + (Source_container (Contract source_contract)) + (Sink_container (Frozen_bonds (source_contract, bond_id))) (Constants.tx_rollup_commitment_bond ctxt) else return (ctxt, []) ) >>=? fun (ctxt, balance_updates) -> @@ -1621,12 +1641,12 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, slashed) -> if slashed then let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn else return (ctxt, []) | None -> return (ctxt, [])) @@ -1643,12 +1663,12 @@ let apply_external_manager_operation_content : | Tx_rollup_return_bond {tx_rollup} -> Tx_rollup_commitment.remove_bond ctxt tx_rollup source >>=? fun ctxt -> let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (source_contract, bond_id)) + Token.balance ctxt (Frozen_bonds (source_contract, bond_id)) >>=? fun (ctxt, bond) -> Token.transfer ctxt - (`Frozen_bonds (source_contract, bond_id)) - (`Contract source_contract) + (Source_container (Frozen_bonds (source_contract, bond_id))) + (Sink_container (Contract source_contract)) bond >>=? fun (ctxt, balance_updates) -> let result = @@ -1764,19 +1784,19 @@ let apply_external_manager_operation_content : (if slashed then let committer = Contract.Implicit commitment.committer in let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Tez.(burn /? 2L) >>?= fun reward -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn >>=? fun (ctxt, burn_update) -> Token.transfer ctxt - `Tx_rollup_rejection_rewards - (`Contract source_contract) + (Source_infinite Tx_rollup_rejection_rewards) + (Sink_container (Contract source_contract)) reward >>=? fun (ctxt, reward_update) -> return (ctxt, burn_update @ reward_update) @@ -2025,7 +2045,7 @@ let burn_manager_storage_fees : payer:public_key_hash -> (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t = fun ctxt smopr ~storage_limit ~payer -> - let payer = `Contract (Contract.Implicit payer) in + let payer = Token.Source_container (Contract (Contract.Implicit payer)) in match smopr with | Transaction_result transaction_result -> burn_transaction_storage_fees @@ -2137,7 +2157,7 @@ let burn_internal_storage_fees : (context * Z.t * kind successful_internal_manager_operation_result) tzresult Lwt.t = fun ctxt smopr ~storage_limit ~payer -> - let payer = `Contract (Contract.Implicit payer) in + let payer = Token.Source_container (Contract (Contract.Implicit payer)) in match smopr with | ITransaction_result transaction_result -> burn_transaction_storage_fees @@ -2198,7 +2218,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id List.fold_left_es (fun (ctxt, storage_limit, res) imopr -> let (Internal_manager_operation_result (op, mopr)) = imopr in - match mopr with + match[@coq_match_gadt] mopr with | Applied smopr -> burn_internal_storage_fees ctxt @@ -2308,8 +2328,8 @@ let take_fees ctxt (_ : Validate_operation.stamp) contents_list = let+ ctxt, balance_updates = Token.transfer ctxt - (`Contract (Contract.Implicit source)) - `Block_fees + (Source_container (Contract (Contract.Implicit source))) + (Sink_container Block_fees) fee in (ctxt, {contents; balance_updates}) @@ -2326,7 +2346,7 @@ let take_fees ctxt (_ : Validate_operation.stamp) contents_list = let*! result = take_fees_rec ctxt contents_list in Lwt.return (record_trace Error_while_taking_fees result) -let rec apply_manager_contents_list_rec : +let[@coq_axiom_with_reason "gadts"] rec apply_manager_contents_list_rec : type kind. context -> Script_ir_translator.unparsing_mode -> @@ -2394,7 +2414,7 @@ let mark_backtracked results = Internal_manager_operation_result (kind, mark_internal_manager_operation_result result) in - match results with + match[@coq_match_with_default] results with | Manager_operation_result op -> Manager_operation_result { @@ -2447,7 +2467,7 @@ let get_predecessor_level = function let record_operation (type kind) ctxt hash (operation : kind operation) : context = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> ctxt | Single (Endorsement _) -> ctxt | Single (Dal_slot_availability _) -> ctxt @@ -2472,7 +2492,7 @@ type 'consensus_op_kind expected_consensus_content = { let compute_expected_consensus_content (type consensus_op_kind) ~(current_level : Level.t) ~(proposal_level : Level.t) (ctxt : context) (application_mode : apply_mode) - (operation_kind : consensus_op_kind consensus_operation_type) + (operation_kind : consensus_op_kind Consensus_operation_type.t) (operation_round : Round.t) (operation_level : Raw_level.t) : (context * consensus_op_kind expected_consensus_content) tzresult Lwt.t = match operation_kind with @@ -2577,7 +2597,7 @@ let check_operation_branch ~expected ~provided = (Block_hash.equal expected provided) (Wrong_consensus_operation_branch (expected, provided)) -let check_round (type kind) (operation_kind : kind consensus_operation_type) +let check_round (type kind) (operation_kind : kind Consensus_operation_type.t) (apply_mode : apply_mode) ~(expected : Round.t) ~(provided : Round.t) : unit tzresult = match apply_mode with @@ -2603,7 +2623,7 @@ let check_round (type kind) (operation_kind : kind consensus_operation_type) let check_consensus_content (type kind) (apply_mode : apply_mode) (content : consensus_content) (operation_branch : Block_hash.t) - (operation_kind : kind consensus_operation_type) + (operation_kind : kind Consensus_operation_type.t) (expected_content : kind expected_consensus_content) : unit tzresult = let expected_level = expected_content.level.level in let provided_level = content.level in @@ -2630,8 +2650,8 @@ let check_consensus_content (type kind) (apply_mode : apply_mode) to the grandfather: the block hash used in the payload_hash. Otherwise we could produce a preendorsement pointing to the direct proposal. This preendorsement wouldn't be able to propagate for a subsequent proposal using it as a locked_round evidence. *) -let validate_consensus_contents (type kind) ctxt chain_id - (operation_kind : kind consensus_operation_type) +let[@coq_axiom_with_reason "bug in coq-of-ocaml"] validate_consensus_contents + (type kind) ctxt chain_id (operation_kind : kind Consensus_operation_type.t) (operation : kind operation) (apply_mode : apply_mode) (content : consensus_content) : (context * public_key_hash * int) tzresult Lwt.t = @@ -2715,13 +2735,15 @@ let check_denunciation_age ctxt kind given_level = (Outdated_denunciation {kind; level = given_level; last_cycle = last_slashable_cycle}) +type mistake = Double_baking | Double_endorsing + let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = let already_slashed, punish = match mistake with - | `Double_baking -> + | Double_baking -> ( Delegate.already_slashed_for_double_baking, Delegate.punish_double_baking ) - | `Double_endorsing -> + | Double_endorsing -> ( Delegate.already_slashed_for_double_endorsing, Delegate.punish_double_endorsing ) in @@ -2732,8 +2754,8 @@ let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = | Ok reward -> Token.transfer ctxt - `Double_signing_evidence_rewards - (`Contract (Contract.Implicit payload_producer)) + (Source_infinite Double_signing_evidence_rewards) + (Sink_container (Contract (Contract.Implicit payload_producer))) reward | Error _ -> (* reward is Tez.zero *) return (ctxt, [])) >|=? fun (ctxt, reward_balance_updates) -> @@ -2749,13 +2771,15 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id Lwt.t = let mk_result (balance_updates : Receipt.balance_updates) : kind Kind.double_consensus_operation_evidence contents_result = - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement _) -> Double_preendorsement_evidence_result balance_updates | Single (Endorsement _) -> Double_endorsement_evidence_result balance_updates in - match (op1.protocol_data.contents, op2.protocol_data.contents) with + match[@coq_match_with_default] + (op1.protocol_data.contents, op2.protocol_data.contents) + with | Single (Preendorsement e1), Single (Preendorsement e2) | Single (Endorsement e1), Single (Endorsement e2) -> let kind = if preendorsement then Preendorsement else Endorsement in @@ -2791,7 +2815,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id ctxt delegate level - `Double_endorsing + Double_endorsing mk_result ~payload_producer @@ -2834,7 +2858,7 @@ let punish_double_baking ctxt chain_id bh1 bh2 ~payload_producer = ctxt delegate level - `Double_baking + Double_baking ~payload_producer (fun balance_updates -> Double_baking_evidence_result balance_updates) @@ -2855,7 +2879,7 @@ let is_parent_endorsement ctxt ~proposal_level ~grand_parent_round let validate_grand_parent_endorsement ctxt chain_id (op : Kind.endorsement operation) = - match op.protocol_data.contents with + match[@coq_match_with_default] op.protocol_data.contents with | Single (Endorsement e) -> let level = Level.from_raw ctxt e.level in Stake_distribution.slot_owner ctxt level e.slot @@ -2963,14 +2987,18 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode Nonce.reveal ctxt level nonce >>=? fun ctxt -> let tip = Constants.seed_nonce_revelation_tip ctxt in let contract = Contract.Implicit payload_producer in - Token.transfer ctxt `Revelation_rewards (`Contract contract) tip + Token.transfer + ctxt + (Source_infinite Revelation_rewards) + (Sink_container (Contract contract)) + tip >|=? fun (ctxt, balance_updates) -> (ctxt, Single_result (Seed_nonce_revelation_result balance_updates)) | Single (Vdf_revelation {solution}) -> Seed.check_vdf_and_update_seed ctxt solution >>=? fun ctxt -> let tip = Constants.seed_nonce_revelation_tip ctxt in let contract = Contract.Implicit payload_producer in - Token.transfer ctxt `Revelation_rewards (`Contract contract) tip + Token.transfer ctxt (Source_infinite Revelation_rewards) (Sink_container (Contract contract)) tip >|=? fun (ctxt, balance_updates) -> (ctxt, Single_result (Vdf_revelation_result balance_updates)) | Single (Double_preendorsement_evidence {op1; op2}) -> @@ -2995,12 +3023,16 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode let blinded_pkh = Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in - let src = `Collected_commitments blinded_pkh in + let src = Token.Collected_commitments blinded_pkh in Token.allocated ctxt src >>=? fun (ctxt, src_exists) -> fail_unless src_exists (Invalid_activation {pkh}) >>=? fun () -> let contract = Contract.Implicit (Signature.Ed25519 pkh) in Token.balance ctxt src >>=? fun (ctxt, amount) -> - Token.transfer ctxt src (`Contract contract) amount + Token.transfer + ctxt + (Source_container src) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, bupds) -> return (ctxt, Single_result (Activate_account_result bupds)) | Single (Proposals {source; period; proposals}) -> @@ -3124,8 +3156,8 @@ let apply_liquidity_baking_subsidy ctxt ~toggle_vote = Token.transfer ~origin:Subsidy ctxt - `Liquidity_baking_subsidies - (`Contract liquidity_baking_cpmm_contract) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract liquidity_baking_cpmm_contract)) liquidity_baking_subsidy >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt liquidity_baking_cpmm_contract_hash diff --git a/src/proto_014_PtKathma/lib_protocol/apply_results.ml b/src/proto_014_PtKathma/lib_protocol/apply_results.ml index d8d4b8276a2a5..45e817d9cfb12 100644 --- a/src/proto_014_PtKathma/lib_protocol/apply_results.ml +++ b/src/proto_014_PtKathma/lib_protocol/apply_results.ml @@ -238,7 +238,7 @@ module Manager_result = struct ~title:"Applied" (merge_objs (obj1 (req "status" (constant "applied"))) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> ( match select (Successful_manager_result o) with @@ -268,7 +268,7 @@ module Manager_result = struct (opt "errors" trace_encoding)) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Applied _ -> None | Backtracked (o, errs) -> ( match select (Successful_manager_result o) with @@ -279,7 +279,7 @@ module Manager_result = struct in MCase {op_case; encoding; kind; select; proj; inj; t} - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make ~op_case:Operation.Encoding.Manager_operations.reveal_case ~encoding: @@ -289,10 +289,11 @@ module Manager_result = struct | Successful_manager_result (Reveal_result _ as op) -> Some op | _ -> None) ~kind:Kind.Reveal_manager_kind - ~proj:(function Reveal_result {consumed_gas} -> consumed_gas) + ~proj:(function[@coq_match_with_default] + | Reveal_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> Reveal_result {consumed_gas}) - let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = + let transaction_contract_variant_cases = union [ case @@ -396,7 +397,7 @@ module Manager_result = struct Transaction_to_sc_rollup_result {consumed_gas; inbox_after}); ] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make ~op_case:Operation.Encoding.Manager_operations.transaction_case ~encoding:transaction_contract_variant_cases @@ -404,10 +405,10 @@ module Manager_result = struct | Successful_manager_result (Transaction_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function Transaction_result x -> x) + ~proj:(function[@coq_match_with_default] Transaction_result x -> x) ~inj:(fun x -> Transaction_result x) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make ~op_case:Operation.Encoding.Manager_operations.origination_case ~encoding: @@ -421,7 +422,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Origination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Origination_result { lazy_storage_diff; @@ -460,7 +461,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make ~op_case: Operation.Encoding.Manager_operations.register_global_constant_case @@ -474,7 +475,7 @@ module Manager_result = struct | Successful_manager_result (Register_global_constant_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Register_global_constant_result {balance_updates; consumed_gas; size_of_constant; global_address} -> (balance_updates, consumed_gas, size_of_constant, global_address)) @@ -509,7 +510,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Set_deposits_limit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Set_deposits_limit_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> Set_deposits_limit_result {consumed_gas}) @@ -526,13 +527,13 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Increase_paid_storage_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Increase_paid_storage_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Increase_paid_storage_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_origination_case ~encoding: @@ -546,7 +547,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_origination_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_origination_result {balance_updates; consumed_gas; originated_tx_rollup} -> (balance_updates, consumed_gas, originated_tx_rollup)) @@ -554,7 +555,7 @@ module Manager_result = struct Tx_rollup_origination_result {balance_updates; consumed_gas; originated_tx_rollup}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_submit_batch_case ~encoding: @@ -568,7 +569,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_submit_batch_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_submit_batch_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -576,7 +577,7 @@ module Manager_result = struct Tx_rollup_submit_batch_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_commit_case ~encoding: @@ -588,13 +589,13 @@ module Manager_result = struct | Successful_manager_result (Tx_rollup_commit_result _ as op) -> Some op | _ -> None) ~kind:Kind.Tx_rollup_commit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_commit_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Tx_rollup_commit_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_return_bond_case ~encoding: @@ -607,13 +608,13 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_return_bond_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_return_bond_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Tx_rollup_return_bond_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_finalize_commitment_case @@ -629,7 +630,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_finalize_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, consumed_gas, level)) @@ -637,7 +638,7 @@ module Manager_result = struct Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_remove_commitment_case @@ -653,7 +654,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_remove_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_remove_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, consumed_gas, level)) @@ -661,7 +662,7 @@ module Manager_result = struct Tx_rollup_remove_commitment_result {balance_updates; consumed_gas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_rejection_case ~encoding: @@ -674,13 +675,13 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_rejection_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_rejection_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Tx_rollup_rejection_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_dispatch_tickets_case @@ -696,7 +697,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_dispatch_tickets_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_dispatch_tickets_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -704,7 +705,7 @@ module Manager_result = struct Tx_rollup_dispatch_tickets_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make ~op_case:Operation.Encoding.Manager_operations.transfer_ticket_case ~encoding: @@ -717,7 +718,7 @@ module Manager_result = struct | Successful_manager_result (Transfer_ticket_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transfer_ticket_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Transfer_ticket_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -725,7 +726,7 @@ module Manager_result = struct Transfer_ticket_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] dal_publish_slot_header_case = + let dal_publish_slot_header_case = make ~op_case: Operation.Encoding.Manager_operations.dal_publish_slot_header_case @@ -735,12 +736,12 @@ module Manager_result = struct | Successful_manager_result (Dal_publish_slot_header_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Dal_publish_slot_header_result {consumed_gas} -> consumed_gas) ~kind:Kind.Dal_publish_slot_header_manager_kind ~inj:(fun consumed_gas -> Dal_publish_slot_header_result {consumed_gas}) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make ~op_case:Operation.Encoding.Manager_operations.sc_rollup_originate_case ~encoding: @@ -753,7 +754,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_originate_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_originate_result {balance_updates; address; consumed_gas; size} -> (balance_updates, address, consumed_gas, size)) @@ -773,7 +774,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_add_messages_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_add_messages_result {consumed_gas; inbox_after} -> (consumed_gas, inbox_after)) ~kind:Kind.Sc_rollup_add_messages_manager_kind @@ -788,7 +789,8 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Sc_rollup_cement_result _ as op) -> Some op | _ -> None) - ~proj:(function Sc_rollup_cement_result {consumed_gas} -> consumed_gas) + ~proj:(function[@coq_match_with_default] + | Sc_rollup_cement_result {consumed_gas} -> consumed_gas) ~kind:Kind.Sc_rollup_cement_manager_kind ~inj:(fun consumed_gas -> Sc_rollup_cement_result {consumed_gas}) @@ -805,7 +807,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_publish_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_publish_result {consumed_gas; staked_hash; published_at_level; balance_updates} -> (consumed_gas, staked_hash, published_at_level, balance_updates)) @@ -827,7 +829,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Sc_rollup_refute_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_refute_result {consumed_gas; status; balance_updates} -> (consumed_gas, status, balance_updates)) ~kind:Kind.Sc_rollup_refute_manager_kind @@ -846,7 +848,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_timeout_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_timeout_result {consumed_gas; status; balance_updates} -> (consumed_gas, status, balance_updates)) ~kind:Kind.Sc_rollup_timeout_manager_kind @@ -870,7 +872,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Sc_rollup_execute_outbox_message_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_execute_outbox_message_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -878,7 +880,7 @@ module Manager_result = struct Sc_rollup_execute_outbox_message_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] sc_rollup_recover_bond_case = + let sc_rollup_recover_bond_case = make ~op_case:Operation.Encoding.Manager_operations.sc_rollup_recover_bond_case ~encoding: @@ -891,13 +893,13 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Sc_rollup_recover_bond_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_recover_bond_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> Sc_rollup_recover_bond_result {balance_updates; consumed_gas}) - let[@coq_axiom_with_reason "gadt"] sc_rollup_dal_slot_subscribe_case = + let sc_rollup_dal_slot_subscribe_case = make ~op_case: Operation.Encoding.Manager_operations.sc_rollup_dal_slot_subscribe_case @@ -911,7 +913,7 @@ module Manager_result = struct (Sc_rollup_dal_slot_subscribe_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_dal_slot_subscribe_result {consumed_gas; slot_index; level} -> (consumed_gas, slot_index, level)) @@ -922,20 +924,23 @@ end let successful_manager_operation_result_encoding : packed_successful_manager_operation_result Data_encoding.t = - let make (type kind) - (Manager_result.MCase res_case : kind Manager_result.case) = - let (Operation.Encoding.Manager_operations.MCase op_case) = - res_case.op_case - in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs (obj1 (req "kind" (constant op_case.name))) res_case.encoding) - (fun res -> - match res_case.select res with - | Some res -> Some ((), res_case.proj res) - | None -> None) - (fun ((), res) -> Successful_manager_result (res_case.inj res)) + let make (type kind) (mcase : kind Manager_result.case) = + match[@coq_grab_existentials] mcase with + | Manager_result.MCase res_case -> + let (Operation.Encoding.Manager_operations.MCase op_case) = + res_case.op_case + in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj1 (req "kind" (constant op_case.name))) + res_case.encoding) + (fun res -> + match res_case.select res with + | Some res -> Some ((), res_case.proj res) + | None -> None) + (fun ((), res) -> Successful_manager_result (res_case.inj res)) in def "operation.alpha.successful_manager_operation_result" @@ union @@ -1123,7 +1128,7 @@ module Encoding = struct (fun x -> match proj x with None -> None | Some x -> Some ((), x)) (fun ((), x) -> inj x) - let[@coq_axiom_with_reason "gadt"] preendorsement_case = + let preendorsement_case = Case { op_case = Operation.Encoding.preendorsement_case; @@ -1141,7 +1146,7 @@ module Encoding = struct | Contents_and_result ((Preendorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Preendorsement_result {balance_updates; delegate; preendorsement_power} -> (balance_updates, delegate, preendorsement_power)); @@ -1151,7 +1156,7 @@ module Encoding = struct {balance_updates; delegate; preendorsement_power}); } - let[@coq_axiom_with_reason "gadt"] endorsement_case = + let endorsement_case = Case { op_case = Operation.Encoding.endorsement_case; @@ -1168,7 +1173,7 @@ module Encoding = struct | Contents_and_result ((Endorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Endorsement_result {balance_updates; delegate; endorsement_power} -> (balance_updates, delegate, endorsement_power)); inj = @@ -1176,7 +1181,7 @@ module Encoding = struct Endorsement_result {balance_updates; delegate; endorsement_power}); } - let[@coq_axiom_with_reason "gadt"] dal_slot_availability_case = + let dal_slot_availability_case = Case { op_case = Operation.Encoding.dal_slot_availability_case; @@ -1190,11 +1195,13 @@ module Encoding = struct | Contents_and_result ((Dal_slot_availability _ as op), res) -> Some (op, res) | _ -> None); - proj = (function Dal_slot_availability_result {delegate} -> delegate); + proj = + (function[@coq_match_with_default] + | Dal_slot_availability_result {delegate} -> delegate); inj = (fun delegate -> Dal_slot_availability_result {delegate}); } - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { op_case = Operation.Encoding.seed_nonce_revelation_case; @@ -1209,11 +1216,13 @@ module Encoding = struct | Contents_and_result ((Seed_nonce_revelation _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Seed_nonce_revelation_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation_result bus) -> + bus); inj = (fun bus -> Seed_nonce_revelation_result bus); } - let[@coq_axiom_with_reason "gadt"] vdf_revelation_case = + let vdf_revelation_case = Case { op_case = Operation.Encoding.vdf_revelation_case; @@ -1227,11 +1236,11 @@ module Encoding = struct (function | Contents_and_result ((Vdf_revelation _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Vdf_revelation_result bus) -> bus); + proj = (fun[@coq_match_with_default] (Vdf_revelation_result bus) -> bus); inj = (fun bus -> Vdf_revelation_result bus); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case = + let double_endorsement_evidence_case = Case { op_case = Operation.Encoding.double_endorsement_evidence_case; @@ -1247,11 +1256,14 @@ module Encoding = struct | Contents_and_result ((Double_endorsement_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_endorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_endorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case = + let double_preendorsement_evidence_case = Case { op_case = Operation.Encoding.double_preendorsement_evidence_case; @@ -1268,11 +1280,14 @@ module Encoding = struct -> Some (op, res) | _ -> None); - proj = (fun (Double_preendorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_preendorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { op_case = Operation.Encoding.double_baking_evidence_case; @@ -1287,11 +1302,13 @@ module Encoding = struct | Contents_and_result ((Double_baking_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_baking_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence_result bus) -> + bus); inj = (fun bus -> Double_baking_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { op_case = Operation.Encoding.activate_account_case; @@ -1306,11 +1323,12 @@ module Encoding = struct | Contents_and_result ((Activate_account _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Activate_account_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Activate_account_result bus) -> bus); inj = (fun bus -> Activate_account_result bus); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { op_case = Operation.Encoding.proposals_case; @@ -1322,11 +1340,11 @@ module Encoding = struct (function | Contents_and_result ((Proposals _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Proposals_result -> ()); + proj = (fun [@coq_match_with_default] Proposals_result -> ()); inj = (fun () -> Proposals_result); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { op_case = Operation.Encoding.ballot_case; @@ -1338,11 +1356,11 @@ module Encoding = struct (function | Contents_and_result ((Ballot _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Ballot_result -> ()); + proj = (fun [@coq_match_with_default] Ballot_result -> ()); inj = (fun () -> Ballot_result); } - let[@coq_axiom_with_reason "gadt"] make_manager_case (type kind) + let make_manager_case (type kind) (Operation.Encoding.Case op_case : kind Kind.manager Operation.Encoding.case) (Manager_result.MCase res_case : kind Manager_result.case) mselect = @@ -1358,7 +1376,7 @@ module Encoding = struct (list internal_manager_operation_result_encoding) []); select = - (function + (function[@coq_match_gadt] | Contents_result (Manager_operation_result ({operation_result = Applied res; _} as op)) -> ( @@ -1408,12 +1426,12 @@ module Encoding = struct | Contents_result Proposals_result -> None); mselect; proj = - (fun (Manager_operation_result - { - balance_updates = bus; - operation_result = r; - internal_operation_results = rs; - }) -> + (fun [@coq_match_with_default] (Manager_operation_result + { + balance_updates = bus; + operation_result = r; + internal_operation_results = rs; + }) -> (bus, r, rs)); inj = (fun (bus, r, rs) -> @@ -1425,7 +1443,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make_manager_case Operation.Encoding.reveal_case Manager_result.reveal_case @@ -1435,7 +1453,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make_manager_case Operation.Encoding.transaction_case Manager_result.transaction_case @@ -1445,7 +1463,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make_manager_case Operation.Encoding.origination_case Manager_result.origination_case @@ -1455,7 +1473,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = make_manager_case Operation.Encoding.delegation_case Manager_result.delegation_case @@ -1465,7 +1483,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make_manager_case Operation.Encoding.register_global_constant_case Manager_result.register_global_constant_case @@ -1477,7 +1495,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = make_manager_case Operation.Encoding.set_deposits_limit_case Manager_result.set_deposits_limit_case @@ -1488,7 +1506,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] increase_paid_storage_case = + let increase_paid_storage_case = make_manager_case Operation.Encoding.increase_paid_storage_case Manager_result.increase_paid_storage_case @@ -1499,7 +1517,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make_manager_case Operation.Encoding.tx_rollup_origination_case Manager_result.tx_rollup_origination_case @@ -1510,7 +1528,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make_manager_case Operation.Encoding.tx_rollup_submit_batch_case Manager_result.tx_rollup_submit_batch_case @@ -1521,7 +1539,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make_manager_case Operation.Encoding.tx_rollup_commit_case Manager_result.tx_rollup_commit_case @@ -1532,7 +1550,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make_manager_case Operation.Encoding.tx_rollup_return_bond_case Manager_result.tx_rollup_return_bond_case @@ -1543,7 +1561,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make_manager_case Operation.Encoding.tx_rollup_finalize_commitment_case Manager_result.tx_rollup_finalize_commitment_case @@ -1555,7 +1573,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make_manager_case Operation.Encoding.tx_rollup_remove_commitment_case Manager_result.tx_rollup_remove_commitment_case @@ -1567,7 +1585,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make_manager_case Operation.Encoding.tx_rollup_rejection_case Manager_result.tx_rollup_rejection_case @@ -1578,7 +1596,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make_manager_case Operation.Encoding.tx_rollup_dispatch_tickets_case Manager_result.tx_rollup_dispatch_tickets_case @@ -1590,7 +1608,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make_manager_case Operation.Encoding.transfer_ticket_case Manager_result.transfer_ticket_case @@ -1601,7 +1619,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] dal_publish_slot_header_case = + let dal_publish_slot_header_case = make_manager_case Operation.Encoding.dal_publish_slot_header_case Manager_result.dal_publish_slot_header_case @@ -1613,7 +1631,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make_manager_case Operation.Encoding.sc_rollup_originate_case Manager_result.sc_rollup_originate_case @@ -1624,7 +1642,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = make_manager_case Operation.Encoding.sc_rollup_add_messages_case Manager_result.sc_rollup_add_messages_case @@ -1635,7 +1653,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = make_manager_case Operation.Encoding.sc_rollup_cement_case Manager_result.sc_rollup_cement_case @@ -1646,7 +1664,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = make_manager_case Operation.Encoding.sc_rollup_publish_case Manager_result.sc_rollup_publish_case @@ -1657,7 +1675,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_refute_case = + let sc_rollup_refute_case = make_manager_case Operation.Encoding.sc_rollup_refute_case Manager_result.sc_rollup_refute_case @@ -1668,7 +1686,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_timeout_case = + let sc_rollup_timeout_case = make_manager_case Operation.Encoding.sc_rollup_timeout_case Manager_result.sc_rollup_timeout_case @@ -1679,7 +1697,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_execute_outbox_message_case = + let sc_rollup_execute_outbox_message_case = make_manager_case Operation.Encoding.sc_rollup_execute_outbox_message_case Manager_result.sc_rollup_execute_outbox_message_case @@ -1691,7 +1709,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_recover_bond_case = + let sc_rollup_recover_bond_case = make_manager_case Operation.Encoding.sc_rollup_recover_bond_case Manager_result.sc_rollup_recover_bond_case @@ -1717,8 +1735,9 @@ end let contents_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; _}; encoding; @@ -1726,10 +1745,12 @@ let contents_result_encoding = select; proj; inj; - }) = - let proj x = match select x with None -> None | Some x -> Some (proj x) in - let inj x = Contents_result (inj x) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj x = + match select x with None -> None | Some x -> Some (proj x) + in + let inj x = Contents_result (inj x) in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.contents_result" @@ union @@ -1775,8 +1796,9 @@ let contents_result_encoding = let contents_and_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _}; mselect; @@ -1784,15 +1806,17 @@ let contents_and_result_encoding = proj = meta_proj; inj = meta_inj; _; - }) = - let proj c = - match mselect c with - | Some (op, res) -> Some (proj op, meta_proj res) - | _ -> None - in - let inj (op, res) = Contents_and_result (inj op, meta_inj res) in - let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj c = + match mselect c with + | Some (op, res) -> Some (proj op, meta_proj res) + | _ -> None + in + let inj (op, res) = Contents_and_result (inj op, meta_inj res) in + let encoding = + merge_objs encoding (obj1 (req "metadata" meta_encoding)) + in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.operation_contents_and_result" @@ union @@ -1848,27 +1872,34 @@ type packed_contents_result_list = 'kind contents_result_list -> packed_contents_result_list +let rec contents_result_list_to_list : type kind. kind contents_result_list -> _ + = function + | Single_result o -> [Contents_result o] + | Cons_result (o, os) -> Contents_result o :: contents_result_list_to_list os + +let packed_contents_result_list_to_list = function + | Contents_result_list l -> contents_result_list_to_list l + +let rec packed_contents_result_list_of_list = function + | [] -> Error "cannot decode empty operation result" + | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) + | Contents_result o :: os -> ( + packed_contents_result_list_of_list os + >>? fun (Contents_result_list os) -> + match (o, os) with + | Manager_operation_result _, Single_result (Manager_operation_result _) + -> + Ok (Contents_result_list (Cons_result (o, os))) + | Manager_operation_result _, Cons_result _ -> + Ok (Contents_result_list (Cons_result (o, os))) + | _ -> Error "cannot decode ill-formed operation result") + let contents_result_list_encoding = - let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - in - let rec of_list = function - | [] -> Error "cannot decode empty operation result" - | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) - | Contents_result o :: os -> ( - of_list os >>? fun (Contents_result_list os) -> - match (o, os) with - | Manager_operation_result _, Single_result (Manager_operation_result _) - -> - Ok (Contents_result_list (Cons_result (o, os))) - | Manager_operation_result _, Cons_result _ -> - Ok (Contents_result_list (Cons_result (o, os))) - | _ -> Error "cannot decode ill-formed operation result") - in def "operation.alpha.contents_list_result" - @@ conv_with_guard to_list of_list (list contents_result_encoding) + @@ conv_with_guard + packed_contents_result_list_to_list + packed_contents_result_list_of_list + (list contents_result_encoding) type 'kind contents_and_result_list = | Single_and_result : @@ -1885,27 +1916,34 @@ type packed_contents_and_result_list = 'kind contents_and_result_list -> packed_contents_and_result_list +let rec contents_and_result_list_to_list : + type kind. kind contents_and_result_list -> _ = function + | Single_and_result (op, res) -> [Contents_and_result (op, res)] + | Cons_and_result (op, res, rest) -> + Contents_and_result (op, res) :: contents_and_result_list_to_list rest + +let packed_contents_and_result_list_to_list = function + | Contents_and_result_list l -> contents_and_result_list_to_list l + +let rec packed_contents_and_result_list_of_list = function + | [] -> Error "cannot decode empty combined operation result" + | [Contents_and_result (op, res)] -> + Ok (Contents_and_result_list (Single_and_result (op, res))) + | Contents_and_result (op, res) :: rest -> ( + packed_contents_and_result_list_of_list rest + >>? fun (Contents_and_result_list rest) -> + match (op, rest) with + | Manager_operation _, Single_and_result (Manager_operation _, _) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | Manager_operation _, Cons_and_result (_, _, _) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | _ -> Error "cannot decode ill-formed combined operation result") + let contents_and_result_list_encoding = - let rec to_list = function - | Contents_and_result_list (Single_and_result (op, res)) -> - [Contents_and_result (op, res)] - | Contents_and_result_list (Cons_and_result (op, res, rest)) -> - Contents_and_result (op, res) :: to_list (Contents_and_result_list rest) - in - let rec of_list = function - | [] -> Error "cannot decode empty combined operation result" - | [Contents_and_result (op, res)] -> - Ok (Contents_and_result_list (Single_and_result (op, res))) - | Contents_and_result (op, res) :: rest -> ( - of_list rest >>? fun (Contents_and_result_list rest) -> - match (op, rest) with - | Manager_operation _, Single_and_result (Manager_operation _, _) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | Manager_operation _, Cons_and_result (_, _, _) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | _ -> Error "cannot decode ill-formed combined operation result") - in - conv_with_guard to_list of_list (Variable.list contents_and_result_encoding) + conv_with_guard + packed_contents_and_result_list_to_list + packed_contents_and_result_list_of_list + (Variable.list contents_and_result_encoding) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -1935,11 +1973,11 @@ let operation_metadata_encoding = (fun () -> No_operation_metadata); ] -let kind_equal : +let[@coq_axiom_with_reason "gadt"] kind_equal : type kind kind2. kind contents -> kind2 contents_result -> (kind, kind2) eq option = fun op res -> - match (op, res) with + match[@coq_match_gadt] (op, res) with | Endorsement _, Endorsement_result _ -> Some Eq | Endorsement _, _ -> None | Preendorsement _, Preendorsement_result _ -> Some Eq @@ -1968,13 +2006,12 @@ let kind_equal : (* the Failing_noop operation always fails and can't have result *) None | ( Manager_operation {operation = Reveal _; _}, - Manager_operation_result {operation_result = Applied (Reveal_result _); _} - ) -> - Some Eq + Manager_operation_result {operation_result = Applied applied; _} ) -> ( + match applied with Reveal_result _ -> Some Eq | _ -> None) | ( Manager_operation {operation = Reveal _; _}, - Manager_operation_result - {operation_result = Backtracked (Reveal_result _, _); _} ) -> - Some Eq + Manager_operation_result {operation_result = Backtracked (applied, _); _} + ) -> ( + match applied with Reveal_result _ -> Some Eq | _ -> None) | ( Manager_operation {operation = Reveal _; _}, Manager_operation_result { @@ -2679,13 +2716,13 @@ let rec kind_equal_list : | Some Eq -> Some Eq)) | _ -> None -let[@coq_axiom_with_reason "gadt"] rec pack_contents_list : +let rec pack_contents_list : type kind. kind contents_list -> kind contents_result_list -> kind contents_and_result_list = fun contents res -> - match (contents, res) with + match[@coq_match_with_default] (contents, res) with | Single op, Single_result res -> Single_and_result (op, res) | Cons (op, ops), Cons_result (res, ress) -> Cons_and_result (op, res, pack_contents_list ops ress) @@ -2719,11 +2756,6 @@ let rec unpack_contents_list : let ops, ress = unpack_contents_list rest in (Cons (op, ops), Cons_result (res, ress)) -let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - let operation_data_and_metadata_encoding = def "operation.alpha.operation_with_metadata" @@ union diff --git a/src/proto_014_PtKathma/lib_protocol/apply_results.mli b/src/proto_014_PtKathma/lib_protocol/apply_results.mli index 08f47c7c7cbbc..67704dc37172a 100644 --- a/src/proto_014_PtKathma/lib_protocol/apply_results.mli +++ b/src/proto_014_PtKathma/lib_protocol/apply_results.mli @@ -313,7 +313,8 @@ val unpack_contents_list : 'kind contents_and_result_list -> 'kind contents_list * 'kind contents_result_list -val to_list : packed_contents_result_list -> packed_contents_result list +val packed_contents_result_list_to_list : + packed_contents_result_list -> packed_contents_result list type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/proto_014_PtKathma/lib_protocol/baking.ml b/src/proto_014_PtKathma/lib_protocol/baking.ml index 00bc864d91028..8c5175342eb86 100644 --- a/src/proto_014_PtKathma/lib_protocol/baking.ml +++ b/src/proto_014_PtKathma/lib_protocol/baking.ml @@ -70,7 +70,7 @@ let bonus_baking_reward ctxt ~endorsing_power = Tez.(baking_reward_bonus_per_slot *? Int64.of_int extra_endorsing_power) let baking_rights c level = - let rec f c round = + let[@coq_struct "round"] rec f c round = Stake_distribution.baking_rights_owner c level ~round >>=? fun (c, _slot, (delegate, _)) -> return (LCons (delegate, fun () -> f c (Round.succ round))) diff --git a/src/proto_014_PtKathma/lib_protocol/blinded_public_key_hash.ml b/src/proto_014_PtKathma/lib_protocol/blinded_public_key_hash.ml index 7b0a3272cc6ee..38a8f65138c2d 100644 --- a/src/proto_014_PtKathma/lib_protocol/blinded_public_key_hash.ml +++ b/src/proto_014_PtKathma/lib_protocol/blinded_public_key_hash.ml @@ -26,15 +26,17 @@ module H = Blake2B.Make (Base58) - (struct - let name = "Blinded public key hash" + (( + struct + let name = "Blinded public key hash" - let title = "A blinded public key hash" + let title = "A blinded public key hash" - let b58check_prefix = "\001\002\049\223" + let b58check_prefix = "\001\002\049\223" - let size = Some Ed25519.Public_key_hash.size - end) + let size = Some Ed25519.Public_key_hash.size + end : + Blake2B.PrefixedName)) module Index : Storage_description.INDEX with type t = H.t = struct include H diff --git a/src/proto_014_PtKathma/lib_protocol/bond_id_repr.ml b/src/proto_014_PtKathma/lib_protocol/bond_id_repr.ml index 665d0e64d5bfd..ad9ce24f1477a 100644 --- a/src/proto_014_PtKathma/lib_protocol/bond_id_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/bond_id_repr.ml @@ -74,7 +74,7 @@ let rpc_arg = let starts_with ~prefix s = let open String in let len_s = length s and len_pre = length prefix in - let rec aux i = + let[@coq_struct "i_value"] rec aux i = if Compare.Int.(i = len_pre) then true else if Compare.Char.(get s i <> get prefix i) then false else aux (i + 1) diff --git a/src/proto_014_PtKathma/lib_protocol/bootstrap_storage.ml b/src/proto_014_PtKathma/lib_protocol/bootstrap_storage.ml index b9abaec549892..76c3115a17f6d 100644 --- a/src/proto_014_PtKathma/lib_protocol/bootstrap_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/bootstrap_storage.ml @@ -48,8 +48,8 @@ let init_account (ctxt, balance_updates) Token.transfer ~origin:Protocol_migration ctxt - `Bootstrap - (`Contract contract) + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) amount >>=? fun (ctxt, new_balance_updates) -> (match public_key with @@ -87,7 +87,12 @@ let init_contract ~typecheck (ctxt, balance_updates) | Some delegate -> Delegate_storage.init ctxt contract delegate) >>=? fun ctxt -> let origin = Receipt_repr.Protocol_migration in - Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount + Token.transfer + ~origin + ctxt + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) + amount >|=? fun (ctxt, new_balance_updates) -> (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_014_PtKathma/lib_protocol/cache_repr.ml b/src/proto_014_PtKathma/lib_protocol/cache_repr.ml index 603e3e82848c4..5496e714a4085 100644 --- a/src/proto_014_PtKathma/lib_protocol/cache_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/cache_repr.ml @@ -264,15 +264,17 @@ let register_exn (type cvalue) >>?= fun ctxt -> Admin.find ctxt (mk ~id) >>= function | None -> return None - | Some (K v) -> return (Some v) - | _ -> - (* This execution path is impossible because all the keys of - C's namespace (which is unique to C) are constructed with - [K]. This [assert false] could have been pushed into the - environment in exchange for extra complexity. The - argument that justifies this [assert false] seems - simple enough to keep the current design though. *) - assert false + | Some value -> ( + match value with + | K v -> return (Some v) + | _ -> + (* This execution path is impossible because all the keys of + C's namespace (which is unique to C) are constructed with + [K]. This [assert false] could have been pushed into the + environment in exchange for extra complexity. The + argument that justifies this [assert false] seems + simple enough to keep the current design though. *) + assert false) let list_identifiers ctxt = Admin.list_keys ctxt ~cache_index:C.cache_index |> function diff --git a/src/proto_014_PtKathma/lib_protocol/carbonated_map.ml b/src/proto_014_PtKathma/lib_protocol/carbonated_map.ml index dcd812c9836c9..28e8a3da72ba9 100644 --- a/src/proto_014_PtKathma/lib_protocol/carbonated_map.ml +++ b/src/proto_014_PtKathma/lib_protocol/carbonated_map.ml @@ -91,7 +91,16 @@ module type COMPARABLE = sig val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t end -module Make_builder (C : COMPARABLE) = struct +module type S_builder = sig + type 'a t + + type key + + module Make (G : GAS) : + S with type key = key and type context = G.context and type 'a t := 'a t +end + +module Make_builder (C : COMPARABLE) : S_builder with type key := C.t = struct module M = Map.Make (C) type 'a t = {map : 'a M.t; size : int} diff --git a/src/proto_014_PtKathma/lib_protocol/carbonated_map.mli b/src/proto_014_PtKathma/lib_protocol/carbonated_map.mli index 60de5b15667c7..e175569b172f8 100644 --- a/src/proto_014_PtKathma/lib_protocol/carbonated_map.mli +++ b/src/proto_014_PtKathma/lib_protocol/carbonated_map.mli @@ -136,18 +136,22 @@ module type COMPARABLE = sig val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t end +module type S_builder = sig + type 'a t + + type key + + module Make (G : GAS) : + S with type key = key and type context = G.context and type 'a t := 'a t +end + (** A functor for exposing the type of a carbonated map before the carbonated make is created. This is useful in scenarios where the map that will need to be carbonated is defined before the gas consuming functions for the carbonation are available. See for example [Raw_context]. *) -module Make_builder (C : COMPARABLE) : sig - type 'a t - - module Make (G : GAS) : - S with type key = C.t and type context = G.context and type 'a t := 'a t -end +module Make_builder (C : COMPARABLE) : S_builder with type key := C.t (** A functor for building gas metered maps. When building a gas metered map via [Make(G)(C)], [C] is a [COMPARABLE] required to construct a the map while diff --git a/src/proto_014_PtKathma/lib_protocol/cycle_repr.ml b/src/proto_014_PtKathma/lib_protocol/cycle_repr.ml index b1a4b8bc6e0b9..21dc8929c3553 100644 --- a/src/proto_014_PtKathma/lib_protocol/cycle_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/cycle_repr.ml @@ -34,8 +34,9 @@ let rpc_arg = RPC_arg.like RPC_arg.uint31 ~descr:"A cycle integer" "block_cycle" let pp ppf cycle = Format.fprintf ppf "%ld" cycle -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 +include M module Map = Map.Make (Compare.Int32) let root = 0l diff --git a/src/proto_014_PtKathma/lib_protocol/delegate_storage.ml b/src/proto_014_PtKathma/lib_protocol/delegate_storage.ml index cd9095e5fe58b..85440cd38a69f 100644 --- a/src/proto_014_PtKathma/lib_protocol/delegate_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/delegate_storage.ml @@ -362,8 +362,8 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Sufficient participation: we pay the rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Contract delegate_contract) + (Source_infinite Endorsing_rewards) + (Sink_container (Contract delegate_contract)) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates) @@ -371,9 +371,10 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Insufficient participation or unrevealed nonce: no rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Lost_endorsing_rewards - (delegate, not sufficient_participation, not has_revealed_nonces)) + (Source_infinite Endorsing_rewards) + (Sink_infinite + (Lost_endorsing_rewards + (delegate, not sufficient_participation, not has_revealed_nonces))) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates)) @@ -477,8 +478,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) to_reimburse >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else if Tez_repr.(current_amount < maximum_stake_to_be_deposited) then @@ -498,8 +499,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Delegate_balance delegate) - (`Frozen_deposits delegate) + (Source_container (Delegate_balance delegate)) + (Sink_container (Frozen_deposits delegate)) to_freeze >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -525,8 +526,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) frozen_deposits.current_amount >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -744,7 +745,7 @@ module Random = struct the sequence and try again). *) Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop (bytes, n) = + let[@coq_struct "function_parameter"] rec loop (bytes, n) = let consumed_bytes = 8 in let state_size = Bytes.length bytes in if Compare.Int.(n > state_size - consumed_bytes) then @@ -827,8 +828,8 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -858,8 +859,8 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -938,15 +939,22 @@ let record_baking_activity_and_pay_rewards_and_fees ctxt ~payload_producer >>=? fun ctxt -> let pay_payload_producer ctxt delegate = let contract = Contract_repr.Implicit delegate in - Token.balance ctxt `Block_fees >>=? fun (ctxt, block_fees) -> + Token.balance ctxt Block_fees >>=? fun (ctxt, block_fees) -> Token.transfer_n ctxt - [(`Block_fees, block_fees); (`Baking_rewards, baking_reward)] - (`Contract contract) + [ + (Source_container Block_fees, block_fees); + (Source_infinite Baking_rewards, baking_reward); + ] + (Sink_container (Contract contract)) in let pay_block_producer ctxt delegate bonus = let contract = Contract_repr.Implicit delegate in - Token.transfer ctxt `Baking_bonuses (`Contract contract) bonus + Token.transfer + ctxt + (Source_infinite Baking_bonuses) + (Sink_container (Contract contract)) + bonus in pay_payload_producer ctxt payload_producer >>=? fun (ctxt, balance_updates_payload_producer) -> diff --git a/src/proto_014_PtKathma/lib_protocol/dependent_bool.ml b/src/proto_014_PtKathma/lib_protocol/dependent_bool.ml index 26d5bd7a9b5e4..e82e863c8822d 100644 --- a/src/proto_014_PtKathma/lib_protocol/dependent_bool.ml +++ b/src/proto_014_PtKathma/lib_protocol/dependent_bool.ml @@ -36,7 +36,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] let dand : type a b. a dbool -> b dbool -> (a, b) ex_dand = fun a b -> @@ -57,7 +57,7 @@ type (_, _) eq = Eq : ('a, 'a) eq let merge_dand : type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq = fun w1 w2 -> - match (w1, w2) with + match[@coq_match_with_default] (w1, w2) with | NoNo, NoNo -> Eq | NoYes, NoYes -> Eq | YesNo, YesNo -> Eq diff --git a/src/proto_014_PtKathma/lib_protocol/dependent_bool.mli b/src/proto_014_PtKathma/lib_protocol/dependent_bool.mli index 54416d9fd9c3e..a5265a36a14f0 100644 --- a/src/proto_014_PtKathma/lib_protocol/dependent_bool.mli +++ b/src/proto_014_PtKathma/lib_protocol/dependent_bool.mli @@ -46,7 +46,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] (** Logical conjunction of dependent booleans. *) val dand : 'a dbool -> 'b dbool -> ('a, 'b) ex_dand diff --git a/src/proto_014_PtKathma/lib_protocol/fees_storage.ml b/src/proto_014_PtKathma/lib_protocol/fees_storage.ml index 134b46d1470ec..e7c3b1bff8cf1 100644 --- a/src/proto_014_PtKathma/lib_protocol/fees_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/fees_storage.ml @@ -89,7 +89,7 @@ let record_paid_storage_space ctxt contract = let source_must_exist c src = match src with - | `Contract src -> Contract_storage.must_exist c src + | Token.Source_container (Contract src) -> Contract_storage.must_exist c src | _ -> return_unit let burn_storage_fees ?(origin = Receipt_repr.Block_application) c @@ -108,7 +108,7 @@ let burn_storage_fees ?(origin = Receipt_repr.Block_application) c trace Cannot_pay_storage_fee ( source_must_exist c payer >>=? fun () -> - Token.transfer ~origin c payer `Storage_fees to_burn + Token.transfer ~origin c payer (Sink_infinite Storage_fees) to_burn >>=? fun (ctxt, balance_updates) -> return (ctxt, remaining, balance_updates) ) @@ -122,7 +122,7 @@ let burn_storage_increase_fees ?(origin = Receipt_repr.Block_application) c trace Cannot_pay_storage_fee ( source_must_exist c payer >>=? fun () -> - Token.transfer ~origin c payer `Storage_fees to_burn ) + Token.transfer ~origin c payer (Sink_infinite Storage_fees) to_burn ) let burn_origination_fees ?(origin = Receipt_repr.Block_application) c ~storage_limit ~payer = diff --git a/src/proto_014_PtKathma/lib_protocol/fitness_repr.ml b/src/proto_014_PtKathma/lib_protocol/fitness_repr.ml index 8abc162cf5427..dcaf851549bec 100644 --- a/src/proto_014_PtKathma/lib_protocol/fitness_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/fitness_repr.ml @@ -167,10 +167,10 @@ let locked_round_to_bytes = function | Some locked_round -> int32_to_bytes (Round_repr.to_int32 locked_round) let locked_round_of_bytes b = - match Bytes.length b with - | 0 -> ok None - | 4 -> Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) - | _ -> error Invalid_fitness + if Compare.Int.(Bytes.length b = 0) then ok None + else if Compare.Int.(Bytes.length b = 4) then + Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) + else error Invalid_fitness let predecessor_round_of_bytes neg_predecessor_round = int32_of_bytes neg_predecessor_round >>? fun neg_predecessor_round -> diff --git a/src/proto_014_PtKathma/lib_protocol/gas_comparable_input_size.ml b/src/proto_014_PtKathma/lib_protocol/gas_comparable_input_size.ml index 62831ed1d33b1..d592d2cada5dc 100644 --- a/src/proto_014_PtKathma/lib_protocol/gas_comparable_input_size.ml +++ b/src/proto_014_PtKathma/lib_protocol/gas_comparable_input_size.ml @@ -105,7 +105,7 @@ let tx_rollup_l2_address x = let timestamp (tstamp : Script_timestamp.t) : t = Z.numbits (Script_timestamp.to_zint tstamp) / 8 -let rec size_of_comparable_value : +let[@coq_axiom_with_reason "gadts"] rec size_of_comparable_value : type a. a Script_typed_ir.comparable_ty -> a -> t = fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) -> match wit with diff --git a/src/proto_014_PtKathma/lib_protocol/gas_input_size.ml b/src/proto_014_PtKathma/lib_protocol/gas_input_size.ml index 1a35ae6ea9e13..561ac86c9a1a9 100644 --- a/src/proto_014_PtKathma/lib_protocol/gas_input_size.ml +++ b/src/proto_014_PtKathma/lib_protocol/gas_input_size.ml @@ -52,7 +52,7 @@ let node leaves = let r = List.fold_left ( ++ ) micheline_zero leaves in {r with traversal = r.traversal + 1} -let rec of_micheline (x : ('a, 'b) Micheline.node) = +let[@coq_struct "x_value"] rec of_micheline (x : ('a, 'b) Micheline.node) = match x with | Micheline.Int (_loc, z) -> let int_bytes = integer (Script_int.of_zint z) in diff --git a/src/proto_014_PtKathma/lib_protocol/gas_monad.ml b/src/proto_014_PtKathma/lib_protocol/gas_monad.ml index 3597f4bfa47f6..ba4d9045c0601 100644 --- a/src/proto_014_PtKathma/lib_protocol/gas_monad.ml +++ b/src/proto_014_PtKathma/lib_protocol/gas_monad.ml @@ -46,7 +46,7 @@ let ( >>?? ) m f = match m with None -> None | Some x -> f x let bind m f gas = m gas >>?? fun (res, gas) -> - match res with Ok y -> f y gas | Error _ as err -> of_result err gas + match res with Ok y -> f y gas | Error err -> of_result (Error err) gas [@@ocaml.inline always] let map f m gas = m gas >>?? fun (x, gas) -> of_result (x >|? f) gas @@ -79,7 +79,7 @@ let run ctxt m = ok (res, ctxt) | None -> error Gas.Operation_quota_exceeded) -let record_trace_eval : +let[@coq_axiom_with_reason "type being matched is not informative enough."] record_trace_eval : type error_trace error_context. error_details:(error_context, error_trace) Script_tc_errors.error_details -> (error_context -> error) -> diff --git a/src/proto_014_PtKathma/lib_protocol/global_constants_storage.ml b/src/proto_014_PtKathma/lib_protocol/global_constants_storage.ml index f00b2f3330c51..ee0aa4f00b96c 100644 --- a/src/proto_014_PtKathma/lib_protocol/global_constants_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/global_constants_storage.ml @@ -225,7 +225,7 @@ let expand context expr = with [Expression_too_deep] if greater than [max_allowed_global_constant_depth].*) let check_depth node = - let rec advance node depth k = + let[@coq_struct "node_value"] rec advance node depth k = if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth) then error Expression_too_deep else diff --git a/src/proto_014_PtKathma/lib_protocol/indexable.ml b/src/proto_014_PtKathma/lib_protocol/indexable.ml index 0dce5fd663ed1..670450c0d98d9 100644 --- a/src/proto_014_PtKathma/lib_protocol/indexable.ml +++ b/src/proto_014_PtKathma/lib_protocol/indexable.ml @@ -93,9 +93,9 @@ let forget : type state a. (state, a) t -> (unknown, a) t = function | Hidden_value x | Value x -> Hidden_value x | Hidden_index x | Index x -> Hidden_index x -let to_int32 = function Index x -> x +let to_int32 = function[@coq_match_with_default] Index x -> x -let to_value = function Value x -> x +let to_value = function[@coq_match_with_default] Value x -> x let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = fun ~error v -> @@ -104,7 +104,8 @@ let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = let compact val_encoding = Data_encoding.Compact.( conv - (function Hidden_index x -> Either.Left x | Hidden_value x -> Right x) + (function[@coq_match_with_default] + | Hidden_index x -> Either.Left x | Hidden_value x -> Right x) (function Left x -> Hidden_index x | Right x -> Hidden_value x) @@ or_int32 ~int32_title:"index" ~alt_title:"value" val_encoding) @@ -148,10 +149,13 @@ let compare : | (Hidden_value _ | Value _), (Hidden_index _ | Index _) -> 1 let compare_values c : 'a value -> 'a value -> int = - fun (Value x) (Value y) -> c x y + fun x y -> + match[@coq_match_with_default] (x, y) with Value x, Value y -> c x y let compare_indexes : 'a index -> 'a index -> int = - fun (Index x) (Index y) -> Compare.Int32.compare x y + fun x y -> + match[@coq_match_with_default] (x, y) with + | Index x, Index y -> Compare.Int32.compare x y module type VALUE = sig type t @@ -163,7 +167,41 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) = struct +module type INDEXABLE = sig + type v_t + + type nonrec 'state t = ('state, v_t) t + + type nonrec index = v_t index + + type nonrec value = v_t value + + type nonrec either = v_t either + + val value : v_t -> value + + val index : int32 -> index tzresult + + val index_exn : int32 -> index + + val compact : either Data_encoding.Compact.t + + val encoding : either Data_encoding.t + + val index_encoding : index Data_encoding.t + + val value_encoding : value Data_encoding.t + + val compare : 'state t -> 'state' t -> int + + val compare_values : value -> value -> int + + val compare_indexes : index -> index -> int + + val pp : Format.formatter -> 'state t -> unit +end + +module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct type nonrec 'state t = ('state, V.t) t type nonrec index = V.t index @@ -172,28 +210,35 @@ module Make (V : VALUE) = struct type nonrec either = V.t either - let value = value + let value : V.t -> value = value - let index = index + let index : int32 -> index tzresult = index - let index_exn = index_exn + let index_exn : int32 -> index = index_exn - let compact = compact V.encoding + let compact : either Data_encoding.Compact.t = compact V.encoding - let encoding = encoding V.encoding + let encoding : either Data_encoding.t = encoding V.encoding let index_encoding : index Data_encoding.t = Data_encoding.( - conv (fun (Index x) -> x) (fun x -> Index x) Data_encoding.int32) + conv + (fun [@coq_match_with_default] (Index x) -> x) + (fun x -> Index x) + Data_encoding.int32) let value_encoding : value Data_encoding.t = - Data_encoding.(conv (fun (Value x) -> x) (fun x -> Value x) V.encoding) + Data_encoding.( + conv + (fun [@coq_match_with_default] (Value x) -> x) + (fun x -> Value x) + V.encoding) let pp : Format.formatter -> 'state t -> unit = fun fmt x -> pp V.pp fmt x - let compare_values = compare_values V.compare + let compare_values : value -> value -> int = compare_values V.compare - let compare_indexes = compare_indexes + let compare_indexes : index -> index -> int = compare_indexes let compare : 'state t -> 'state' t -> int = fun x y -> compare V.compare x y end diff --git a/src/proto_014_PtKathma/lib_protocol/indexable.mli b/src/proto_014_PtKathma/lib_protocol/indexable.mli index cc921e802f1f6..e71d8926bc4a5 100644 --- a/src/proto_014_PtKathma/lib_protocol/indexable.mli +++ b/src/proto_014_PtKathma/lib_protocol/indexable.mli @@ -162,16 +162,18 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) : sig - type nonrec 'state t = ('state, V.t) t +module type INDEXABLE = sig + type v_t - type nonrec index = V.t index + type nonrec 'state t = ('state, v_t) t - type nonrec value = V.t value + type nonrec index = v_t index - type nonrec either = V.t either + type nonrec value = v_t value - val value : V.t -> value + type nonrec either = v_t either + + val value : v_t -> value val index : int32 -> index tzresult @@ -194,4 +196,6 @@ module Make (V : VALUE) : sig val pp : Format.formatter -> 'state t -> unit end +module Make (V : VALUE) : INDEXABLE with type v_t := V.t + type error += Index_cannot_be_negative of int32 diff --git a/src/proto_014_PtKathma/lib_protocol/init_storage.ml b/src/proto_014_PtKathma/lib_protocol/init_storage.ml index 0f11030b6cc47..f90760f10bd72 100644 --- a/src/proto_014_PtKathma/lib_protocol/init_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/init_storage.ml @@ -40,8 +40,8 @@ let invoice_contract ctxt ~address ~amount_mutez = Token.transfer ~origin:Protocol_migration ctxt - `Invoice - (`Contract recipient) + (Source_infinite Invoice) + (Sink_container (Contract recipient)) amount ) >|= function | Ok res -> res @@ -94,8 +94,8 @@ let prepare_first_block chain_id ctxt ~typecheck ~level ~timestamp = Commitment_repr.{blinded_public_key_hash; amount} = Token.transfer ctxt - `Initial_commitments - (`Collected_commitments blinded_public_key_hash) + (Source_infinite Initial_commitments) + (Sink_container (Collected_commitments blinded_public_key_hash)) amount >>=? fun (ctxt, new_balance_updates) -> return (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_014_PtKathma/lib_protocol/level_repr.ml b/src/proto_014_PtKathma/lib_protocol/level_repr.ml index 0b5926f387f57..cc16715354fcb 100644 --- a/src/proto_014_PtKathma/lib_protocol/level_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/level_repr.ml @@ -130,7 +130,8 @@ let create_cycle_eras cycle_eras = match cycle_eras with | [] -> error Invalid_cycle_eras | newest_era :: older_eras -> - let rec aux {first_level; first_cycle; _} older_eras = + let rec aux era older_eras = + let {first_level; first_cycle; _} = era in match older_eras with | ({ first_level = first_level_of_previous_era; diff --git a/src/proto_014_PtKathma/lib_protocol/level_storage.ml b/src/proto_014_PtKathma/lib_protocol/level_storage.ml index 852e8a84899b9..bc2795c83dfa2 100644 --- a/src/proto_014_PtKathma/lib_protocol/level_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/level_storage.ml @@ -73,7 +73,7 @@ let last_level_in_cycle ctxt c = let levels_in_cycle ctxt cycle = let first = first_level_in_cycle ctxt cycle in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc) else acc in @@ -89,7 +89,7 @@ let levels_in_current_cycle ctxt ?(offset = 0l) () = let levels_with_commitments_in_cycle ctxt c = let first = first_level_in_cycle ctxt c in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then if n.expected_commitment then loop (succ ctxt n) (n :: acc) else loop (succ ctxt n) acc diff --git a/src/proto_014_PtKathma/lib_protocol/liquidity_baking_migration.ml b/src/proto_014_PtKathma/lib_protocol/liquidity_baking_migration.ml index 4f4d13dfa38eb..643c0d37608ad 100644 --- a/src/proto_014_PtKathma/lib_protocol/liquidity_baking_migration.ml +++ b/src/proto_014_PtKathma/lib_protocol/liquidity_baking_migration.ml @@ -124,20 +124,20 @@ let originate ctxt address_hash ~balance script = ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) >>=? fun (ctxt, _, origination_updates) -> Fees_storage.burn_storage_fees ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) size >>=? fun (ctxt, _, storage_updates) -> Token.transfer ~origin:Protocol_migration ctxt - `Liquidity_baking_subsidies - (`Contract address) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract address)) balance >>=? fun (ctxt, transfer_updates) -> let balance_updates = diff --git a/src/proto_014_PtKathma/lib_protocol/merkle_list.ml b/src/proto_014_PtKathma/lib_protocol/merkle_list.ml index 9f9aaa0c6da9d..93e671434f84e 100644 --- a/src/proto_014_PtKathma/lib_protocol/merkle_list.ml +++ b/src/proto_014_PtKathma/lib_protocol/merkle_list.ml @@ -88,12 +88,14 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t = struct +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t = +struct type h = H.t type elt = El.t @@ -145,7 +147,7 @@ end) let empty = H.zero - let root = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h + let root_aux = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h let nil = {tree = Empty; depth = 0; next_pos = 0} @@ -155,7 +157,7 @@ end) let hash2 h1 h2 = H.(hash_bytes [to_bytes h1; to_bytes h2]) - let node_of t1 t2 = Node (hash2 (root t1) (root t2), t1, t2) + let node_of t1 t2 = Node (hash2 (root_aux t1) (root_aux t2), t1, t2) (* to_bin computes the [depth]-long binary representation of [pos] (left-padding with 0s if required). This corresponds to the tree traversal @@ -164,25 +166,25 @@ end) Pre-condition: pos >= 0 /| pos < 2^depth Post-condition: len(to_bin pos depth) = depth *) let to_bin ~pos ~depth = - let rec aux acc pos depth = + let[@coq_struct "depth"] rec aux acc pos depth = let pos', dir = (pos / 2, pos mod 2) in match depth with | 0 -> acc | d -> aux (Compare.Int.(dir = 1) :: acc) pos' (d - 1) in - aux [] pos depth + aux List.nil pos depth (* Constructs a tree of a given depth in which every right subtree is empty * and the only leaf contains the hash of el. *) let make_spine_with el = - let rec aux left = function + let[@coq_struct "function_parameter"] rec aux left = function | 0 -> left | d -> (aux [@tailcall]) (node_of left Empty) (d - 1) in aux (leaf_of el) let snoc t (el : elt) = - let rec traverse tree depth key = + let[@coq_struct "depth"] rec traverse tree depth key = match (tree, key) with | Node (_, t_left, Empty), true :: _key -> (* The base case where the left subtree is full and we start @@ -209,13 +211,13 @@ end) let tree', depth' = match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) - | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) | tree, depth, pos -> - let key = to_bin ~pos ~depth in - (traverse tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} @@ -248,18 +250,18 @@ end) let tree', depth' = match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) - | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) | tree, depth, pos -> - let key = to_bin ~pos ~depth in - (traverse Top tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse Top tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} let rec tree_to_list = function - | Empty -> [] + | Empty -> List.nil | Leaf h -> [h] | Node (_, t_left, t_right) -> tree_to_list t_left @ tree_to_list t_right @@ -280,10 +282,11 @@ end) match (tree, key) with | Leaf _, [] -> ok acc | Node (_, l, r), b :: key -> - if b then aux (root l :: acc) r key else aux (root r :: acc) l key + if b then aux (root_aux l :: acc) r key + else aux (root_aux r :: acc) l key | _ -> error Merkle_list_invalid_position in - aux [] tree key + aux List.nil tree key let check_path path pos el expected_root = let depth = List.length path in @@ -305,17 +308,17 @@ end) let path_depth path = List.length path let compute l = - let rec aux l = + let[@coq_struct "l_value"] rec aux l = let rec pairs acc = function | [] -> List.rev acc | [x] -> List.rev (hash2 x empty :: acc) | x :: y :: xs -> pairs (hash2 x y :: acc) xs in - match pairs [] l with [] -> empty | [h] -> h | pl -> aux pl + match pairs List.nil l with [] -> empty | [h] -> h | pl -> aux pl in aux (List.map hash_elt l) - let root t = root t.tree + let root t = root_aux t.tree module Internal_for_tests = struct let path_to_list x = x diff --git a/src/proto_014_PtKathma/lib_protocol/merkle_list.mli b/src/proto_014_PtKathma/lib_protocol/merkle_list.mli index 2352d451b7738..8a40dbe749eee 100644 --- a/src/proto_014_PtKathma/lib_protocol/merkle_list.mli +++ b/src/proto_014_PtKathma/lib_protocol/merkle_list.mli @@ -107,9 +107,10 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t diff --git a/src/proto_014_PtKathma/lib_protocol/michelson_v1_gas.ml b/src/proto_014_PtKathma/lib_protocol/michelson_v1_gas.ml index a8e6ae52f419c..6a151e95e8162 100644 --- a/src/proto_014_PtKathma/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_014_PtKathma/lib_protocol/michelson_v1_gas.ml @@ -1383,31 +1383,37 @@ module Cost_of = struct | Compare : 'a Script_typed_ir.comparable_ty * 'a * 'a * cont -> cont | Return : cont - let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost = - fun ty x y -> - let rec compare : + module Compare = struct + let[@coq_struct "ty_value"] rec compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost -> cont -> cost = fun ty x y acc k -> - match ty with - | Unit_t -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k - | Never_t -> ( match x with _ -> .) - | Bool_t -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k - | String_t -> (apply [@tailcall]) Gas.(acc +@ compare_string x y) k - | Signature_t -> (apply [@tailcall]) Gas.(acc +@ compare_signature) k - | Bytes_t -> (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k - | Mutez_t -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k - | Int_t -> (apply [@tailcall]) Gas.(acc +@ compare_int x y) k - | Nat_t -> (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k - | Key_hash_t -> (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k - | Key_t -> (apply [@tailcall]) Gas.(acc +@ compare_key) k - | Timestamp_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x, y) with + | Unit_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k + | Never_t, _, _ -> . + | Bool_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k + | String_t, (x : Script_string.t), (y : Script_string.t) -> + (apply [@tailcall]) Gas.(acc +@ compare_string x y) k + | Signature_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_signature) k + | Bytes_t, (x : bytes), (y : bytes) -> + (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k + | Mutez_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k + | Int_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) Gas.(acc +@ compare_int x y) k + | Nat_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k + | Key_hash_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k + | Key_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_key) k + | Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t) -> (apply [@tailcall]) Gas.(acc +@ compare_timestamp x y) k - | Address_t -> (apply [@tailcall]) Gas.(acc +@ compare_address) k - | Tx_rollup_l2_address_t -> + | Address_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_address) k + | Tx_rollup_l2_address_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_tx_rollup_l2_address) k - | Chain_id_t -> (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k - | Pair_t (tl, tr, _, YesYes) -> + | Chain_id_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k + | Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _) -> (* Reasonable over-approximation of the cost of lexicographic comparison. *) let xl, xr = x in let yl, yr = y in @@ -1417,7 +1423,9 @@ module Cost_of = struct yl Gas.(acc +@ compare_pair_tag) (Compare (tr, xr, yr, k)) - | Union_t (tl, tr, _, YesYes) -> ( + | ( Union_t (tl, tr, _, YesYes), + (x : _ Script_typed_ir.union), + (y : _ Script_typed_ir.union) ) -> ( match (x, y) with | L x, L y -> (compare [@tailcall]) tl x y Gas.(acc +@ compare_union_tag) k @@ -1425,7 +1433,7 @@ module Cost_of = struct | R _, L _ -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k | R x, R y -> (compare [@tailcall]) tr x y Gas.(acc +@ compare_union_tag) k) - | Option_t (t, _, Yes) -> ( + | Option_t (t, _, Yes), (x : _ option), (y : _ option) -> ( match (x, y) with | None, None -> (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k @@ -1435,13 +1443,15 @@ module Cost_of = struct (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k | Some x, Some y -> (compare [@tailcall]) t x y Gas.(acc +@ compare_option_tag) k) - and apply cost k = + + and[@coq_mutual_as_notation] apply cost k = match k with | Compare (ty, x, y, k) -> (compare [@tailcall]) ty x y cost k | Return -> cost - in - compare ty x y Gas.free Return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] + end + + let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost = + fun ty x y -> Compare.compare ty x y Gas.free Return let set_mem (type a) (elt : a) (set : a Script_typed_ir.set) = let open S_syntax in diff --git a/src/proto_014_PtKathma/lib_protocol/michelson_v1_primitives.ml b/src/proto_014_PtKathma/lib_protocol/michelson_v1_primitives.ml index abbad29046c1d..fe1a0bfef077e 100644 --- a/src/proto_014_PtKathma/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_014_PtKathma/lib_protocol/michelson_v1_primitives.ml @@ -555,8 +555,10 @@ let prim_of_string = function else error (Invalid_case n) let prims_of_strings expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> ok expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> ok (Int (l, z)) + | String (l, s) -> ok (String (l, s)) + | Bytes (l, b) -> ok (Bytes (l, b)) | Prim (loc, prim, args, annot) -> Error_monad.record_trace (Invalid_primitive_name (expr, loc)) @@ -566,12 +568,12 @@ let prims_of_strings expr = | Seq (loc, args) -> List.map_e convert args >|? fun args -> Seq (loc, args) in convert (root expr) >|? fun expr -> strip_locations expr - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let strings_of_prims expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> Int (l, z) + | String (l, s) -> String (l, s) + | Bytes (l, b) -> Bytes (l, b) | Prim (loc, prim, args, annot) -> let prim = string_of_prim prim in let args = List.map convert args in @@ -581,8 +583,6 @@ let strings_of_prims expr = Seq (loc, args) in strip_locations (convert (root expr)) - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let prim_encoding = let open Data_encoding in diff --git a/src/proto_014_PtKathma/lib_protocol/misc.ml b/src/proto_014_PtKathma/lib_protocol/misc.ml index bd350a5ef85b2..2fe3e7075f447 100644 --- a/src/proto_014_PtKathma/lib_protocol/misc.ml +++ b/src/proto_014_PtKathma/lib_protocol/misc.ml @@ -31,15 +31,15 @@ type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t -let[@coq_struct "i"] rec ( --> ) i j = +let[@coq_struct "i_value"] rec ( --> ) i j = (* [i; i+1; ...; j] *) if Compare.Int.(i > j) then [] else i :: (succ i --> j) -let[@coq_struct "j"] rec ( <-- ) i j = +let[@coq_struct "j_value"] rec ( <-- ) i j = (* [j; j-1; ...; i] *) if Compare.Int.(i > j) then [] else j :: (i <-- pred j) -let[@coq_struct "i"] rec ( ---> ) i j = +let[@coq_struct "i_value"] rec ( ---> ) i j = (* [i; i+1; ...; j] *) if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j) diff --git a/src/proto_014_PtKathma/lib_protocol/operation_repr.ml b/src/proto_014_PtKathma/lib_protocol/operation_repr.ml index 9ee55663a0667..6696c5554a3d1 100644 --- a/src/proto_014_PtKathma/lib_protocol/operation_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/operation_repr.ml @@ -47,6 +47,7 @@ module Kind = struct type 'a double_consensus_operation_evidence = | Double_consensus_operation_evidence + [@@coq_force_gadt] type double_endorsement_evidence = endorsement_consensus_kind double_consensus_operation_evidence @@ -154,15 +155,16 @@ module Kind = struct : sc_rollup_dal_slot_subscribe manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type = struct + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -let pp_operation_kind (type kind) ppf - (operation_kind : kind consensus_operation_type) = - match operation_kind with - | Endorsement -> Format.fprintf ppf "Endorsement" - | Preendorsement -> Format.fprintf ppf "Preendorsement" + let pp (type kind) ppf (operation_kind : kind t) = + match operation_kind with + | Endorsement -> Format.fprintf ppf "Endorsement" + | Preendorsement -> Format.fprintf ppf "Preendorsement" +end type consensus_content = { slot : Slot_repr.t; @@ -203,10 +205,14 @@ let pp_consensus_content ppf content = Block_payload_hash.pp_short content.block_payload_hash -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t +module Consensus_watermark = struct + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t +end + +open Consensus_watermark let bytes_of_consensus_watermark = function | Preendorsement chain_id -> @@ -617,14 +623,14 @@ module Encoding = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = MCase { tag = 0; name = "reveal"; encoding = obj1 (req "public_key" Signature.Public_key.encoding); select = (function Manager (Reveal _ as op) -> Some op | _ -> None); - proj = (function Reveal pkh -> pkh); + proj = (function[@coq_match_with_default] Reveal pkh -> pkh); inj = (fun pkh -> Reveal pkh); } @@ -645,7 +651,7 @@ module Encoding = struct select = (function Manager (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -678,7 +684,7 @@ module Encoding = struct select = (function Manager (Origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = @@ -694,11 +700,11 @@ module Encoding = struct encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); select = (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); + proj = (function[@coq_match_with_default] Delegation key -> key); inj = (fun key -> Delegation key); } - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = MCase { tag = 4; @@ -707,11 +713,13 @@ module Encoding = struct select = (function | Manager (Register_global_constant _ as op) -> Some op | _ -> None); - proj = (function Register_global_constant {value} -> value); + proj = + (function[@coq_match_with_default] + | Register_global_constant {value} -> value); inj = (fun value -> Register_global_constant {value}); } - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = MCase { tag = 5; @@ -720,11 +728,12 @@ module Encoding = struct select = (function | Manager (Set_deposits_limit _ as op) -> Some op | _ -> None); - proj = (function Set_deposits_limit key -> key); + proj = + (function[@coq_match_with_default] Set_deposits_limit key -> key); inj = (fun key -> Set_deposits_limit key); } - let[@coq_axiom_with_reason "gadt"] increase_paid_storage_case = + let increase_paid_storage_case = MCase { tag = 9; @@ -737,7 +746,7 @@ module Encoding = struct (function | Manager (Increase_paid_storage _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Increase_paid_storage {amount_in_bytes; destination} -> (amount_in_bytes, destination)); inj = @@ -745,7 +754,7 @@ module Encoding = struct Increase_paid_storage {amount_in_bytes; destination}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = MCase { tag = tx_rollup_operation_origination_tag; @@ -754,7 +763,8 @@ module Encoding = struct select = (function | Manager (Tx_rollup_origination as op) -> Some op | _ -> None); - proj = (function Tx_rollup_origination -> ()); + proj = + (function[@coq_match_with_default] Tx_rollup_origination -> ()); inj = (fun () -> Tx_rollup_origination); } @@ -764,7 +774,7 @@ module Encoding = struct encoding which is in hexadecimal for JSON. *) conv Bytes.of_string Bytes.to_string bytes - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = MCase { tag = tx_rollup_operation_submit_batch_tag; @@ -778,7 +788,7 @@ module Encoding = struct (function | Manager (Tx_rollup_submit_batch _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> (tx_rollup, content, burn_limit)); inj = @@ -786,7 +796,7 @@ module Encoding = struct Tx_rollup_submit_batch {tx_rollup; content; burn_limit}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = MCase { tag = tx_rollup_operation_commit_tag; @@ -799,14 +809,14 @@ module Encoding = struct (function | Manager (Tx_rollup_commit _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment)); inj = (fun (tx_rollup, commitment) -> Tx_rollup_commit {tx_rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = MCase { tag = tx_rollup_operation_return_bond_tag; @@ -815,11 +825,13 @@ module Encoding = struct select = (function | Manager (Tx_rollup_return_bond _ as op) -> Some op | _ -> None); - proj = (function Tx_rollup_return_bond {tx_rollup} -> tx_rollup); + proj = + (function[@coq_match_with_default] + | Tx_rollup_return_bond {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_return_bond {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = MCase { tag = tx_rollup_operation_finalize_commitment_tag; @@ -830,11 +842,12 @@ module Encoding = struct | Manager (Tx_rollup_finalize_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_finalize_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = MCase { tag = tx_rollup_operation_remove_commitment_tag; @@ -845,11 +858,12 @@ module Encoding = struct | Manager (Tx_rollup_remove_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_remove_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = MCase { tag = tx_rollup_operation_rejection_tag; @@ -878,7 +892,7 @@ module Encoding = struct (function | Manager (Tx_rollup_rejection _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_rejection { tx_rollup; @@ -928,7 +942,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = MCase { tag = tx_rollup_operation_dispatch_tickets_tag; @@ -950,7 +964,7 @@ module Encoding = struct | Manager (Tx_rollup_dispatch_tickets _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_dispatch_tickets { tx_rollup; @@ -984,7 +998,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = MCase { tag = transfer_ticket_tag; @@ -1001,7 +1015,7 @@ module Encoding = struct (function | Manager (Transfer_ticket _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} -> (contents, ty, ticketer, amount, destination, entrypoint)); @@ -1011,7 +1025,7 @@ module Encoding = struct {contents; ty; ticketer; amount; destination; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = MCase { tag = sc_rollup_operation_origination_tag; @@ -1025,7 +1039,7 @@ module Encoding = struct (function | Manager (Sc_rollup_originate _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_originate {kind; boot_sector; parameters_ty} -> (kind, boot_sector, parameters_ty)); inj = @@ -1033,20 +1047,20 @@ module Encoding = struct Sc_rollup_originate {kind; boot_sector; parameters_ty}); } - let[@coq_axiom_with_reason "gadt"] dal_publish_slot_header_case = + let dal_publish_slot_header_case = MCase { tag = dal_publish_slot_header_tag; name = "dal_publish_slot_header"; encoding = obj1 (req "slot" Dal_slot_repr.encoding); select = - (function + (function[@coq_match_with_default] | Manager (Dal_publish_slot_header _ as op) -> Some op | _ -> None); proj = (function Dal_publish_slot_header {slot} -> slot); inj = (fun slot -> Dal_publish_slot_header {slot}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = MCase { tag = sc_rollup_operation_add_message_tag; @@ -1059,14 +1073,14 @@ module Encoding = struct (function | Manager (Sc_rollup_add_messages _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_add_messages {rollup; messages} -> (rollup, messages)); inj = (fun (rollup, messages) -> Sc_rollup_add_messages {rollup; messages}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = MCase { tag = sc_rollup_operation_cement_tag; @@ -1079,13 +1093,13 @@ module Encoding = struct (function | Manager (Sc_rollup_cement _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_cement {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = MCase { tag = sc_rollup_operation_publish_tag; @@ -1098,7 +1112,7 @@ module Encoding = struct (function | Manager (Sc_rollup_publish _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_publish {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_publish {rollup; commitment}); @@ -1255,15 +1269,21 @@ module Encoding = struct encoding = consensus_content_encoding; select = (function Contents (Preendorsement _ as op) -> Some op | _ -> None); - proj = (fun (Preendorsement preendorsement) -> preendorsement); + proj = + (fun [@coq_match_with_default] (Preendorsement preendorsement) -> + preendorsement); inj = (fun preendorsement -> Preendorsement preendorsement); } let preendorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let make = + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.preendorsement contents_list -> _ = function + let to_list : Kind.preendorsement contents_list -> _ = + function[@coq_match_with_default] | Single o -> o in let of_list : Kind.preendorsement contents -> _ = function @@ -1285,19 +1305,17 @@ module Encoding = struct @@ union [make preendorsement_case])) (varopt "signature" Signature.encoding))) - let endorsement_encoding = - obj4 - (req "slot" Slot_repr.encoding) - (req "level" Raw_level_repr.encoding) - (req "round" Round_repr.encoding) - (req "block_payload_hash" Block_payload_hash.encoding) - let endorsement_case = Case { tag = 21; name = "endorsement"; - encoding = endorsement_encoding; + encoding = + obj4 + (req "slot" Slot_repr.encoding) + (req "level" Raw_level_repr.encoding) + (req "round" Round_repr.encoding) + (req "block_payload_hash" Block_payload_hash.encoding); select = (function Contents (Endorsement _ as op) -> Some op | _ -> None); proj = @@ -1311,11 +1329,16 @@ module Encoding = struct Endorsement {slot; level; round; block_payload_hash}); } - let[@coq_axiom_with_reason "gadt"] endorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let endorsement_encoding = + let make = + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.endorsement contents_list -> _ = fun (Single o) -> o in + let to_list : Kind.endorsement contents_list -> _ = + fun [@coq_match_with_default] (Single o) -> o + in let of_list : Kind.endorsement contents -> _ = fun o -> Single o in def "inlined.endorsement" @@ conv @@ -1368,11 +1391,13 @@ module Encoding = struct select = (function | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None); - proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce)); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation {level; nonce}) -> + (level, nonce)); inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce}); } - let[@coq_axiom_with_reason "gadt"] vdf_revelation_case = + let vdf_revelation_case = Case { tag = 8; @@ -1380,11 +1405,11 @@ module Encoding = struct encoding = obj1 (req "solution" Seed_repr.vdf_solution_encoding); select = (function Contents (Vdf_revelation _ as op) -> Some op | _ -> None); - proj = (function Vdf_revelation {solution} -> solution); + proj = (function[@coq_match_with_default] Vdf_revelation {solution} -> solution); inj = (fun solution -> Vdf_revelation {solution}); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case : + let double_preendorsement_evidence_case : Kind.double_preendorsement_evidence case = Case { @@ -1398,12 +1423,14 @@ module Encoding = struct (function | Contents (Double_preendorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_preendorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_preendorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case : - Kind.double_endorsement_evidence case = + let double_endorsement_evidence_case : Kind.double_endorsement_evidence case = Case { tag = 2; @@ -1416,11 +1443,14 @@ module Encoding = struct (function | Contents (Double_endorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { tag = 3; @@ -1432,11 +1462,13 @@ module Encoding = struct select = (function | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2)); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence {bh1; bh2}) -> + (bh1, bh2)); inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2}); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { tag = 4; @@ -1449,13 +1481,14 @@ module Encoding = struct (function | Contents (Activate_account _ as op) -> Some op | _ -> None); proj = - (fun (Activate_account {id; activation_code}) -> + (fun [@coq_match_with_default] (Activate_account + {id; activation_code}) -> (id, activation_code)); inj = (fun (id, activation_code) -> Activate_account {id; activation_code}); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { tag = 5; @@ -1468,14 +1501,14 @@ module Encoding = struct select = (function Contents (Proposals _ as op) -> Some op | _ -> None); proj = - (fun (Proposals {source; period; proposals}) -> + (fun [@coq_match_with_default] (Proposals {source; period; proposals}) -> (source, period, proposals)); inj = (fun (source, period, proposals) -> Proposals {source; period; proposals}); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { tag = 6; @@ -1488,7 +1521,7 @@ module Encoding = struct (req "ballot" Vote_repr.ballot_encoding); select = (function Contents (Ballot _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Ballot {source; period; proposal; ballot} -> (source, period, proposal, ballot)); inj = @@ -1527,8 +1560,9 @@ module Encoding = struct Manager_operation {source; fee; counter; gas_limit; storage_limit; operation} - let[@coq_axiom_with_reason "gadt"] make_manager_case tag (type kind) - (Manager_operations.MCase mcase : kind Manager_operations.case) = + let make_manager_case tag (type kind) = + fun [@coq_grab_existentials] (Manager_operations.MCase mcase : + kind Manager_operations.case) -> Case { tag; @@ -1542,7 +1576,7 @@ module Encoding = struct | Some operation -> Some (Manager_operation {op with operation})) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Manager_operation {operation; _} as op -> (extract op, mcase.proj operation)); inj = (fun (op, contents) -> rebuild op (mcase.inj contents)); @@ -1663,13 +1697,16 @@ module Encoding = struct Manager_operations.sc_rollup_dal_slot_subscribe_case let contents_encoding = - let make (Case {tag; name; encoding; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Contents (inj x)) + let make case_description = + match[@coq_grab_existentials] case_description with + | Case {tag; name; encoding; select; proj; inj} -> + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Contents (inj x)) in def "operation.alpha.contents" @@ union @@ -1767,7 +1804,7 @@ let raw ({shell; protocol_data} : _ operation) = let acceptable_passes (op : packed_operation) = let (Operation_data protocol_data) = op.protocol_data in - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Failing_noop _) -> [] | Single (Preendorsement _) -> [0] | Single (Endorsement _) -> [0] @@ -1840,7 +1877,7 @@ let check_signature (type kind) key chain_id match protocol_data.signature with | None -> error Missing_signature | Some signature -> ( - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Preendorsement _) as contents -> check ~watermark:(to_watermark (Preendorsement chain_id)) diff --git a/src/proto_014_PtKathma/lib_protocol/operation_repr.mli b/src/proto_014_PtKathma/lib_protocol/operation_repr.mli index e9bb750f45b50..ee1c47fab2f7c 100644 --- a/src/proto_014_PtKathma/lib_protocol/operation_repr.mli +++ b/src/proto_014_PtKathma/lib_protocol/operation_repr.mli @@ -183,12 +183,13 @@ module Kind : sig : sc_rollup_dal_slot_subscribe manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot_repr.t; @@ -205,10 +206,14 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t +module Consensus_watermark : sig + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t +end + +open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark diff --git a/src/proto_014_PtKathma/lib_protocol/period_repr.ml b/src/proto_014_PtKathma/lib_protocol/period_repr.ml index 1f2de5752be8f..23a0aa1da5086 100644 --- a/src/proto_014_PtKathma/lib_protocol/period_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/period_repr.ml @@ -101,7 +101,9 @@ module Internal : INTERNAL = struct let pp ppf v = Format.fprintf ppf "%Ld" v - include (Compare.Int64 : Compare.S with type t := t) + module M : Compare.S with type t := t = Compare.Int64 + + include M let zero = 0L diff --git a/src/proto_014_PtKathma/lib_protocol/raw_context.ml b/src/proto_014_PtKathma/lib_protocol/raw_context.ml index 78b85668999ba..6750fe6a2be04 100644 --- a/src/proto_014_PtKathma/lib_protocol/raw_context.ml +++ b/src/proto_014_PtKathma/lib_protocol/raw_context.ml @@ -656,7 +656,7 @@ let storage_error err = error (Storage_error err) let version_key = ["version"] (* This value is set by the snapshot_alpha.sh script, don't change it. *) -let version_value = "kathmandu_014" +let version_value = "alpha_current" let version = "v1" @@ -1108,7 +1108,7 @@ let fold ?depth ctxt k ~order ~init ~f = let config ctxt = Context.config (context ctxt) -module Proof = Context.Proof +(* module Proof = Context.Proof *) let length ctxt key = Context.length (context ctxt) key @@ -1457,6 +1457,76 @@ module Sc_rollup_in_memory_inbox = struct {ctxt with back} end +(** Explicit module to present this file as a record in Coq and reduce the size + of the generated Coq code. *) +module M : T with type t = root = struct + type t = root + + type error += Block_quota_exceeded = Block_quota_exceeded + + type error += Operation_quota_exceeded = Operation_quota_exceeded + + let mem = mem + + let mem_tree = mem_tree + + let get = get + + let get_tree = get_tree + + let find = find + + let find_tree = find_tree + + let list = list + + let init = init + + let init_tree = init_tree + + let update = update + + let update_tree = update_tree + + let add = add + + let add_tree = add_tree + + let remove = remove + + let remove_existing = remove_existing + + let remove_existing_tree = remove_existing_tree + + let add_or_remove = add_or_remove + + let add_or_remove_tree = add_or_remove_tree + + let fold = fold + + let config = config + + module Tree = Tree + + let verify_tree_proof = verify_tree_proof + + let verify_stream_proof = verify_stream_proof + + let equal_config = equal_config + + let project : t -> root = project + + let absolute_key : t -> key -> key = absolute_key + + let consume_gas = consume_gas + + let check_enough_gas = check_enough_gas + + let description : t Storage_description.t = description + + let length = length +end + module Dal = struct type error += | Dal_register_invalid_slot of {length : int; slot : Dal_slot_repr.t} diff --git a/src/proto_014_PtKathma/lib_protocol/raw_context.mli b/src/proto_014_PtKathma/lib_protocol/raw_context.mli index 8cf6e5fedb414..876e18d5ebdca 100644 --- a/src/proto_014_PtKathma/lib_protocol/raw_context.mli +++ b/src/proto_014_PtKathma/lib_protocol/raw_context.mli @@ -412,3 +412,5 @@ module Dal : sig [endorser] for the current level. *) val shards : t -> endorser:Signature.Public_key_hash.t -> int list end + +module M : T with type t = root diff --git a/src/proto_014_PtKathma/lib_protocol/raw_context_intf.ml b/src/proto_014_PtKathma/lib_protocol/raw_context_intf.ml index 39c8b058d78aa..259f9659a06df 100644 --- a/src/proto_014_PtKathma/lib_protocol/raw_context_intf.ml +++ b/src/proto_014_PtKathma/lib_protocol/raw_context_intf.ml @@ -28,9 +28,6 @@ as-is for direct context accesses, and used in {!Storage_functors} to provide restricted views to the context. *) -(** The tree depth of a fold. See the [fold] function for more information. *) -type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] - (** The type for context configuration. If two trees or stores have the same configuration, they will generate the same context hash. *) type config = Context.config @@ -173,7 +170,7 @@ module type VIEW = sig lexicographic order of their keys. For large nodes, it is memory-consuming, use [`Undefined] for a more memory efficient [fold]. *) val fold : - ?depth:depth -> + ?depth:Context.depth -> t -> key -> order:[`Sorted | `Undefined] -> @@ -201,10 +198,6 @@ module type VIEW = sig val length : t -> key -> int Lwt.t end -module Kind = struct - type t = [`Value | `Tree] -end - module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the context, with lazy reads and delayed writes. The trees are Merkle @@ -233,7 +226,7 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> Kind.t + val kind : tree -> Context.Kind.t (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] is a leaf tree and [None] otherwise. It is equivalent to [find t @@ -254,203 +247,6 @@ module type TREE = sig val clear : ?depth:int -> tree -> unit end -module type PROOF = sig - (** Proofs are compact representations of trees which can be shared - between peers. - - This is expected to be used as follows: - - - A first peer runs a function [f] over a tree [t]. While performing - this computation, it records: the hash of [t] (called [before] - below), the hash of [f t] (called [after] below) and a subset of [t] - which is needed to replay [f] without any access to the first peer's - storage. Once done, all these informations are packed into a proof of - type [t] that is sent to the second peer. - - - The second peer generates an initial tree [t'] from [p] and computes - [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before] - and [after]. If they match, they know that the result state [f t'] is a - valid context state, without having to have access to the full storage - of the first peer. *) - - (** The type for file and directory names. *) - type step = string - - (** The type for values. *) - type value = bytes - - (** The type of indices for inodes' children. *) - type index = int - - (** The type for hashes. *) - type hash = Context_hash.t - - (** The type for (internal) inode proofs. - - These proofs encode large directories into a tree-like structure. This - reflects irmin-pack's way of representing nodes and computing - hashes (tree-like representations for nodes scales better than flat - representations). - - [length] is the total number of entries in the children of the inode. - It's the size of the "flattened" version of that inode. [length] can be - used to prove the correctness of operations such [Tree.length] and - [Tree.list ~offset ~length] in an efficient way. - - In proofs with [version.is_binary = false], an inode at depth 0 has a - [length] of at least [257]. Below that threshold a [Node] tag is used in - [tree]. That threshold is [3] when [version.is_binary = true]. - - [proofs] contains the children proofs. It is a sparse list of ['a] values. - These values are associated to their index in the list, and the list is - kept sorted in increasing order of indices. ['a] can be a concrete proof - or a hash of that proof. - - In proofs with [version.is_binary = true], inodes have at most 2 proofs - (indexed 0 or 1). - - In proofs with [version.is_binary = false], inodes have at most 32 proofs - (indexed from 0 to 31). *) - type 'a inode = {length : int; proofs : (index * 'a) list} - - (** The type for inode extenders. - - An extender is a compact representation of a sequence of [inode] which - contain only one child. As for inodes, The ['a] parameter can be a - concrete proof or a hash of that proof. - - If an inode proof contains singleton children [i_0, ..., i_n] such as: - [{length=l; proofs = [ (i_0, {proofs = ... { proofs = [ (i_n, p) ] }})]}], - then it is compressed into the inode extender - [{length=l; segment = [i_0;..;i_n]; proof=p}] sharing the same lenght [l] - and final proof [p]. *) - type 'a inode_extender = {length : int; segment : index list; proof : 'a} - - (** The type for compressed and partial Merkle tree proofs. - - Tree proofs do not provide any guarantee with the ordering of - computations. For instance, if two effects commute, they won't be - distinguishable by this kind of proofs. - - [Value v] proves that a value [v] exists in the store. - - [Blinded_value h] proves a value with hash [h] exists in the store. - - [Node ls] proves that a a "flat" node containing the list of files [ls] - exists in the store. - - In proofs with [version.is_binary = true], the length of [ls] is at most - 2. - - In proofs with [version.is_binary = false], the length of [ls] is at most - 256. - - [Blinded_node h] proves that a node with hash [h] exists in the store. - - [Inode i] proves that an inode [i] exists in the store. - - [Extender e] proves that an inode extender [e] exist in the store. *) - type tree = - | Value of value - | Blinded_value of hash - | Node of (step * tree) list - | Blinded_node of hash - | Inode of inode_tree inode - | Extender of inode_tree inode_extender - - (** The type for inode trees. It is a subset of [tree], limited to nodes. - - [Blinded_inode h] proves that an inode with hash [h] exists in the store. - - [Inode_values ls] is simliar to trees' [Node]. - - [Inode_tree i] is similar to tree's [Inode]. - - [Inode_extender e] is similar to trees' [Extender]. *) - and inode_tree = - | Blinded_inode of hash - | Inode_values of (step * tree) list - | Inode_tree of inode_tree inode - | Inode_extender of inode_tree inode_extender - - (** The type for kinded hashes. *) - type kinded_hash = [`Value of hash | `Node of hash] - - module Stream : sig - (** Stream proofs represent an explicit traversal of a Merle tree proof. - Every element (a node, a value, or a shallow pointer) met is first - "compressed" by shallowing its children and then recorded in the proof. - - As stream proofs directly encode the recursive construction of the - Merkle root hash is slightly simpler to implement: verifier simply - need to hash the compressed elements lazily, without any memory or - choice. - - Moreover, the minimality of stream proofs is trivial to check. - Once the computation has consumed the compressed elements required, - it is sufficient to check that no more compressed elements remain - in the proof. - - However, as the compressed elements contain all the hashes of their - shallow children, the size of stream proofs is larger - (at least double in size in practice) than tree proofs, which only - contains the hash for intermediate shallow pointers. *) - - (** The type for elements of stream proofs. - - [Value v] is a proof that the next element read in the store is the - value [v]. - - [Node n] is a proof that the next element read in the store is the - node [n]. - - [Inode i] is a proof that the next element read in the store is the - inode [i]. - - [Inode_extender e] is a proof that the next element read in the store - is the node extender [e]. *) - type elt = - | Value of value - | Node of (step * kinded_hash) list - | Inode of hash inode - | Inode_extender of hash inode_extender - - (** The type for stream proofs. - - The sequance [e_1 ... e_n] proves that the [e_1], ..., [e_n] are - read in the store in sequence. *) - type t = elt Seq.t - end - - type stream = Stream.t - - (** The type for proofs of kind ['a]. - - A proof [p] proves that the state advanced from [before p] to - [after p]. [state p]'s hash is [before p], and [state p] contains - the minimal information for the computation to reach [after p]. - - [version p] is the proof version, it packs several informations. - - [is_stream] discriminates between the stream proofs and the tree proofs. - - [is_binary] discriminates between proofs emitted from - [Tezos_context(_memory).Context_binary] and - [Tezos_context(_memory).Context]. - - It will also help discriminate between the data encoding techniques used. - - The version is meant to be decoded and encoded using the - {!Tezos_context_helpers.Context.decode_proof_version} and - {!Tezos_context_helpers.Context.encode_proof_version}. *) - type 'a t = { - version : int; - before : kinded_hash; - after : kinded_hash; - state : 'a; - } -end - module type T = sig (** The type for root contexts. *) type root @@ -464,8 +260,6 @@ module type T = sig and type value := value and type tree := tree - module Proof : PROOF - (** [verify p f] runs [f] in checking mode. [f] is a function that takes a tree as input and returns a new version of the tree and a result. [p] is a proof, that is a minimal representation of the tree that contains what [f] @@ -517,7 +311,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, *in some order*. *) - type tree_proof := Proof.tree Proof.t + type tree_proof := Context.Proof.tree Context.Proof.t (** [verify_tree_proof] is the verifier of tree proofs. *) val verify_tree_proof : (tree_proof, 'a) verifier @@ -526,7 +320,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, in the exact same order. *) - type stream_proof := Proof.stream Proof.t + type stream_proof := Context.Proof.stream Context.Proof.t (** [verify_stream] is the verifier of stream proofs. *) val verify_stream_proof : (stream_proof, 'a) verifier diff --git a/src/proto_014_PtKathma/lib_protocol/raw_level_repr.ml b/src/proto_014_PtKathma/lib_protocol/raw_level_repr.ml index 8a888f0f2d3f4..1a19dc0636b69 100644 --- a/src/proto_014_PtKathma/lib_protocol/raw_level_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/raw_level_repr.ml @@ -27,7 +27,9 @@ type t = int32 type raw_level = t -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 + +include M let pp ppf level = Format.fprintf ppf "%ld" level diff --git a/src/proto_014_PtKathma/lib_protocol/round_repr.ml b/src/proto_014_PtKathma/lib_protocol/round_repr.ml index 4f8c5c7b20eec..086e8e8acc468 100644 --- a/src/proto_014_PtKathma/lib_protocol/round_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/round_repr.ml @@ -29,7 +29,9 @@ type t = round module Map = Map.Make (Int32) -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 + +include M let zero = 0l @@ -107,7 +109,7 @@ let encoding = (fun i -> i) (fun i -> match of_int32 i with - | Ok _ as res -> res + | Ok round -> Ok round | Error _ -> Error "Round_repr.encoding: negative round") Data_encoding.int32 diff --git a/src/proto_014_PtKathma/lib_protocol/sampler.ml b/src/proto_014_PtKathma/lib_protocol/sampler.ml index 043e05945f86e..1aab07130e6e3 100644 --- a/src/proto_014_PtKathma/lib_protocol/sampler.ml +++ b/src/proto_014_PtKathma/lib_protocol/sampler.ml @@ -74,7 +74,7 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct alias : int FallbackArray.t; } - let rec init_loop total p alias small large = + let[@coq_struct "small"] rec init_loop total p alias small large = match (small, large) with | [], _ -> List.iter (fun (_, i) -> FallbackArray.set p i total) large | _, [] -> diff --git a/src/proto_014_PtKathma/lib_protocol/sapling_repr.ml b/src/proto_014_PtKathma/lib_protocol/sapling_repr.ml index 0e54e90a57272..7e1bbc0a261e9 100644 --- a/src/proto_014_PtKathma/lib_protocol/sapling_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/sapling_repr.ml @@ -25,6 +25,8 @@ type transaction = Sapling.UTXO.transaction +type legacy_transaction = Sapling.UTXO.Legacy.transaction + let transaction_encoding = Sapling.UTXO.transaction_encoding (* The two data structures in the state are all ordered by position, a diff diff --git a/src/proto_014_PtKathma/lib_protocol/sapling_storage.ml b/src/proto_014_PtKathma/lib_protocol/sapling_storage.ml index 3f151b7578472..88a33e6239695 100644 --- a/src/proto_014_PtKathma/lib_protocol/sapling_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/sapling_storage.ml @@ -240,7 +240,7 @@ module Ciphertexts = struct let add ctx id c pos = Storage.Sapling.Ciphertexts.init (ctx, id) pos c let get_from ctx id offset = - let rec aux (ctx, acc) pos = + let[@coq_struct "function_parameter"] rec aux (ctx, acc) pos = Storage.Sapling.Ciphertexts.find (ctx, id) pos >>=? fun (ctx, c) -> match c with | None -> return (ctx, List.rev acc) @@ -319,7 +319,7 @@ module Roots = struct let mem ctx id root = Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun start_pos -> - let rec aux pos = + let[@coq_struct "pos"] rec aux pos = Storage.Sapling.Roots.get (ctx, id) pos >>=? fun hash -> if Compare.Int.(Sapling.Hash.compare hash root = 0) then return true else diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_arith.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_arith.ml index 2fceb16ac63bf..26d03fbd0ba27 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_arith.ml @@ -286,7 +286,7 @@ module Make (Context : P) : open Monad - module MakeVar (P : sig + module type P_MakeVar = sig type t val name : string @@ -296,8 +296,21 @@ module Make (Context : P) : val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - end) = - struct + end + + module type S_MakeVar = sig + type t + + val create : unit Monad.t + + val get : t Monad.t + + val set : t -> unit Monad.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module MakeVar (P : P_MakeVar) : S_MakeVar with type t := P.t = struct let key = [P.name] let create = set_value key P.encoding P.initial @@ -319,7 +332,7 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end - module MakeDict (P : sig + module type P_MakeDict = sig type t val name : string @@ -327,8 +340,21 @@ module Make (Context : P) : val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - end) = - struct + end + + module type MakeDict_sig = sig + type t + + val get : string -> t option Monad.t + + val set : string -> t -> unit Monad.t + + val mapped_to : string -> t -> state -> bool Lwt.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module MakeDict (P : P_MakeDict) : MakeDict_sig with type t := P.t = struct let key k = [P.name; k] let get k = find_value (key k) P.encoding @@ -338,8 +364,8 @@ module Make (Context : P) : let mapped_to k v state = let open Lwt_syntax in let* state', _ = Monad.(run (set k v) state) in - let* t = Tree.find_tree state (key k) - and* t' = Tree.find_tree state' (key k) in + let* t = Tree.find_tree state (key k) in + let* t' = Tree.find_tree state' (key k) in Lwt.return (Option.equal Tree.equal t t') let pp = @@ -351,13 +377,31 @@ module Make (Context : P) : return @@ fun fmt () -> Format.pp_print_list pp_elem fmt l end - module MakeDeque (P : sig + module type P_MakeDeque = sig type t val name : string val encoding : t Data_encoding.t - end) = + end + + module type MakeDeque_sig = sig + type t + + val top : t option Monad.t + + val push : t -> unit Monad.t + + val pop : t option Monad.t + + val inject : t -> unit Monad.t + + val to_list : t list Monad.t + + val clear : unit Monad.t + end + + module MakeDeque (P : P_MakeDeque) : MakeDeque_sig with type t := P.t = struct (* @@ -427,7 +471,7 @@ module Make (Context : P) : let open Monad.Syntax in let* head_idx = get_head in let* end_idx = get_end in - let rec aux l idx = + let[@coq_struct "idx"] rec aux l idx = if Z.(lt idx head_idx) then return l else let* v = find_value (idx_key idx) P.encoding in @@ -441,9 +485,15 @@ module Make (Context : P) : end module CurrentTick = MakeVar (struct - include Sc_rollup_tick_repr + type t = Sc_rollup_tick_repr.t let name = "tick" + + let initial = Sc_rollup_tick_repr.initial + + let pp = Sc_rollup_tick_repr.pp + + let encoding = Sc_rollup_tick_repr.encoding end) module Vars = MakeDict (struct diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_errors.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_errors.ml index 1e0ef8c0f354f..82e4334a3303d 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_errors.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_errors.ml @@ -71,7 +71,7 @@ type error += Sc_rollup_requested_dal_slot_subscriptions_of_future_level of (Raw_level_repr.t * Raw_level_repr.t) -let () = +let[@coq_axiom_with_reason "Polymorphic variant."] () = register_error_kind `Temporary ~id:"Sc_rollup_max_number_of_available_messages_reached" diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_game_repr.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_game_repr.ml index 95d11924bf3dd..2750f0c6e4ad5 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_game_repr.ml @@ -355,7 +355,7 @@ let game_error reason = let find_choice game tick = let open Lwt_result_syntax in - let rec traverse states = + let[@coq_struct "states"] rec traverse states = match states with | (state, state_tick) :: (next_state, next_tick) :: others -> if Sc_rollup_tick_repr.(tick = state_tick) then @@ -426,7 +426,7 @@ let check_dissection start start_tick stop stop_tick dissection = stop_tick)) | _ -> game_error "Dissection should contain at least 2 elements" in - let rec traverse states = + let[@coq_struct "states"] rec traverse states = match states with | (None, _) :: (Some _, _) :: _ -> game_error "Cannot return to a Some state after being at a None state" @@ -518,5 +518,7 @@ let play game refutation = in match result with | Ok x -> Lwt.return x - | Error (Game_error e) -> Lwt.return @@ game_over e - | Error _ -> Lwt.return @@ game_over "undefined" + | Error e -> ( + match e with + | Game_error e -> Lwt.return @@ game_over e + | _ -> Lwt.return @@ game_over "undefined") diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.ml index 1132b6c857f6f..a9fa3172bc472 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.ml @@ -450,11 +450,13 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end -module MakeHashingScheme (Tree : TREE) : - MerkelizedOperations with type tree = Tree.tree = struct - module Tree = Tree +module MakeHashingScheme (P : TREE) : + MerkelizedOperations with type tree = P.tree = struct + module Tree = P type tree = Tree.tree @@ -628,7 +630,7 @@ module MakeHashingScheme (Tree : TREE) : in (history, inbox) in - let rec aux (history, inbox) = + let[@coq_struct "function_parameter"] rec aux (history, inbox) = if Raw_level_repr.(inbox.level = target_level) then (history, inbox) else aux (archive_level history inbox) in @@ -655,7 +657,8 @@ module MakeHashingScheme (Tree : TREE) : let current_messages_hash () = hash_messages messages in return (messages, history, {inbox with current_messages_hash}) - let add_external_messages history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_external_messages + history inbox level payloads messages = let open Lwt_tzresult_syntax in let*? payloads = List.map_e @@ -668,7 +671,8 @@ module MakeHashingScheme (Tree : TREE) : in return (messages, history, inbox) - let add_messages_no_history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_messages_no_history + inbox level payloads messages = let open Lwt_tzresult_syntax in let* messages, No_history, inbox = add_messages_aux No_history inbox level payloads messages @@ -701,7 +705,8 @@ module MakeHashingScheme (Tree : TREE) : in aux [] ptr_path - let produce_inclusion_proof history inbox1 inbox2 = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] produce_inclusion_proof + history inbox1 inbox2 = let cell_ptr = hash_old_levels_messages inbox2.old_levels_messages in let target_index = Skip_list.index inbox1.old_levels_messages in let (With_history history) = @@ -732,7 +737,15 @@ end include ( MakeHashingScheme (struct - include Context.Tree + let find = Context.Tree.find + + let find_tree = Context.Tree.find_tree + + let add = Context.Tree.add + + let is_empty = Context.Tree.is_empty + + let hash = Context.Tree.hash type t = Context.t @@ -741,6 +754,8 @@ include ( type value = bytes type key = string list + + let __infer_t (_ : t) = () end) : MerkelizedOperations with type tree = Context.tree) @@ -822,7 +837,7 @@ module Proof = struct let* r = get_message_payload tree n in return (tree, r) - let check_hash hash kinded_hash = + let[@coq_axiom_with_reason "Type error."] check_hash hash kinded_hash = match kinded_hash with | `Node h -> Hash.(equal (of_context_hash h) hash) | `Value h -> Hash.(equal (of_context_hash h) hash) @@ -838,7 +853,8 @@ module Proof = struct let*! result = promise in match result with Ok r -> return r | Error _ -> proof_error reason - let rec valid {inbox_level = l; message_counter = n} inbox proof = + let[@coq_axiom_with_reason "Type error."] rec valid + {inbox_level = l; message_counter = n} inbox proof = assert (Z.(geq n zero)) ; let open Lwt_result_syntax in match split_proof proof with diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.mli b/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.mli index 96ca17e61fd14..66fefdf7a871b 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_inbox_repr.mli @@ -291,6 +291,8 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end (** diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_management_protocol.ml index 98856c39a1eb4..10e047f642653 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_management_protocol.ml @@ -72,43 +72,46 @@ let transactions_batch_of_internal ctxt transactions = {Sc_rollup.Outbox.Message.unparsed_parameters; destination; entrypoint} = (* Lookup the contract-hash. *) (* Load the type and entrypoints of the script. *) - let* ( Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}), - ctxt ) = + let* res, ctxt = let* ctxt, _cache_key, cached = Script_cache.find ctxt destination in match cached with | Some (_script, ex_script) -> return (ex_script, ctxt) | None -> fail Sc_rollup_invalid_destination in - (* Find the entrypoint type for the given entrypoint. *) - let*? res, ctxt = - Gas_monad.run - ctxt - (Script_ir_translator.find_entrypoint - ~error_details:(Informative ()) - arg_type - entrypoints - entrypoint) - in - let*? (Ex_ty_cstr {ty = parameters_ty; _}) = res in - (* Parse the parameters according to the entrypoint type. *) - let* parameters, ctxt = - Script_ir_translator.parse_data - ctxt - ~legacy:false - ~allow_forged:true - parameters_ty - (Micheline.root unparsed_parameters) - in - return - ( Transaction - { - destination; - entrypoint; - parameters_ty; - parameters; - unparsed_parameters; - }, - ctxt ) + match[@coq_match_gadt] res with + | Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}) -> ( + (* Find the entrypoint type for the given entrypoint. *) + let*? res, ctxt = + Gas_monad.run + ctxt + ((Script_ir_translator.find_entrypoint [@coq_type_annotation]) + ~error_details:(Informative ()) + arg_type + entrypoints + entrypoint) + in + let*? res = res in + match[@coq_match_gadt] res with + | Script_ir_translator.Ex_ty_cstr {ty = parameters_ty; _} -> + (* Parse the parameters according to the entrypoint type. *) + let* parameters, ctxt = + (Script_ir_translator.parse_data [@coq_type_annotation]) + ctxt + ~legacy:false + ~allow_forged:true + parameters_ty + (Micheline.root unparsed_parameters) + in + return + ( Transaction + { + destination; + entrypoint; + parameters_ty; + parameters; + unparsed_parameters; + }, + ctxt )) in let+ ctxt, transactions = List.fold_left_map_es diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_operations.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_operations.ml index 74d469570a150..aecbeb23221c3 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_operations.ml @@ -106,7 +106,7 @@ let rec validate_ty : | Chest_key_t -> error Sc_rollup_invalid_parameters_type | Lambda_t (_, _, _) -> error Sc_rollup_invalid_parameters_type -and validate_two_tys : +and[@coq_mutual_as_notation] validate_two_tys : type a ac b bc ret. (a, ac) Script_typed_ir.ty -> (b, bc) Script_typed_ir.ty -> diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_proof_repr.ml index 84333262f7aec..e7e3050258557 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_proof_repr.ml @@ -42,11 +42,11 @@ let pp ppf _ = Format.fprintf ppf "Refutation game proof" let start proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in - P.proof_start_state P.proof + P.proof_start_state P.proof_val let stop proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in - P.proof_stop_state P.proof + P.proof_stop_state P.proof_val (* This takes an [input] and checks if it is at or above the given level. It returns [None] if this is the case. @@ -69,12 +69,13 @@ let check p reason = let open Lwt_result_syntax in if p then return () else proof_error reason -let valid snapshot commit_level ~pvm_name proof = +let[@coq_axiom_with_reason "Type errors."] valid snapshot commit_level ~pvm_name + proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in let open Lwt_result_syntax in let* _ = check (String.equal P.name pvm_name) "Incorrect PVM kind" in - let input_requested = P.proof_input_requested P.proof in - let input_given = P.proof_input_given P.proof in + let input_requested = P.proof_input_requested P.proof_val in + let input_given = P.proof_input_given P.proof_val in let* input = match (input_requested, proof.inbox) with | Sc_rollup_PVM_sem.No_input_required, None -> return None @@ -105,7 +106,7 @@ let valid snapshot commit_level ~pvm_name proof = input_given) "Input given is not what inbox proof expects" in - Lwt.map Result.ok (P.verify_proof P.proof) + Lwt.map Result.ok (P.verify_proof P.proof_val) module type PVM_with_context_and_state = sig include Sc_rollups.PVM.S @@ -117,7 +118,8 @@ end type error += Proof_cannot_be_wrapped -let produce pvm_and_state inbox commit_level = +let[@coq_axiom_with_reason "Type errors."] produce pvm_and_state inbox + commit_level = let open Lwt_result_syntax in let (module P : PVM_with_context_and_state) = pvm_and_state in let*! request = P.is_input_state P.state in @@ -140,7 +142,7 @@ let produce pvm_and_state inbox commit_level = let module P_with_proof = struct include P - let proof = pvm_step_proof + let proof_val = pvm_step_proof end in match Sc_rollups.wrap_proof (module P_with_proof) with | Some pvm_step -> return {pvm_step; inbox} diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_refutation_storage.ml index 66e00aa3cca1c..626131f03dea8 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_refutation_storage.ml @@ -49,7 +49,7 @@ let timeout_level ctxt = arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *) let goto_inbox_level ctxt rollup inbox_level commit = let open Lwt_tzresult_syntax in - let rec go ctxt commit = + let[@coq_struct "commit"] rec go ctxt commit = let* info, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup commit in @@ -104,7 +104,7 @@ let get_conflict_point ctxt rollup staker1 staker2 = (* The inbox level of a commitment increases by a fixed amount over the preceding commitment. We use this fact in the following to efficiently traverse both commitment histories towards the conflict points. *) - let rec traverse_in_parallel ctxt commit1 commit2 = + let[@coq_struct "commit1"] rec traverse_in_parallel ctxt commit1 commit2 = (* We know that commit1 <> commit2 at the first call and during recursive calls as well. *) let* commit1_info, ctxt = diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.ml index db14462b787e1..4157c21db439b 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.ml @@ -138,9 +138,11 @@ let () = (fun loc -> Invalid_sc_rollup_address loc) let of_b58check s = + let error () = Error (Format.sprintf "Invalid_sc_rollup_address %s" s) in match Base58.decode s with - | Some (Address.Data hash) -> ok hash - | _ -> Error (Format.sprintf "Invalid_sc_rollup_address %s" s) + | Some data -> ( + match data with Address.Data hash -> ok hash | _ -> error ()) + | _ -> error () let pp = Address.pp diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.mli b/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.mli index e24094de26515..a9b1339d29738 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_repr.mli @@ -61,7 +61,7 @@ module Internal_for_tests : sig val originated_sc_rollup : Origination_nonce.t -> Address.t end -module State_hash : S.HASH +module State_hash : S.HASH [@@coq_plain_module] (** Number of messages consumed by a single commitment. This represents a claim about the shape of the Inbox, which can be disputed as part of a commitment diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_stake_storage.ml index 46ef8abf8d454..bbf1fc8ec6952 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_stake_storage.ml @@ -58,7 +58,7 @@ let deposit_stake ctxt rollup staker = let open Lwt_tzresult_syntax in let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in let staker_contract, stake = get_contract_and_stake ctxt staker in - let* ctxt, staker_balance = Token.balance ctxt (`Contract staker_contract) in + let* ctxt, staker_balance = Token.balance ctxt (Contract staker_contract) in let* () = fail_when Tez_repr.(staker_balance < stake) @@ -74,8 +74,8 @@ let deposit_stake ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Contract staker_contract) - (`Frozen_bonds (staker_contract, bond_id)) + (Source_container (Contract staker_contract)) + (Sink_container (Frozen_bonds (staker_contract, bond_id))) stake in let* ctxt, _size = Store.Stakers.init (ctxt, rollup) staker lcc in @@ -99,8 +99,8 @@ let withdraw_stake ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_bonds (staker_contract, bond_id)) - (`Contract staker_contract) + (Source_container (Frozen_bonds (staker_contract, bond_id))) + (Sink_container (Contract staker_contract)) stake in let* ctxt, _size_freed = @@ -248,7 +248,7 @@ let refine_stake ctxt rollup staker commitment = let new_hash = Commitment.hash commitment in (* TODO: https://gitlab.com/tezos/tezos/-/issues/2559 Add a test checking that L2 nodes can catch up after going offline. *) - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = (* WARNING: Do NOT reorder this sequence of ifs. we must check for staked_on before LCC, since refining from the LCC to another commit is a valid operation. *) @@ -390,15 +390,15 @@ let remove_staker ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_bonds (staker_contract, bond_id)) - `Sc_rollup_refutation_punishments + (Source_container (Frozen_bonds (staker_contract, bond_id))) + (Sink_infinite Sc_rollup_refutation_punishments) stake in let* ctxt, _size_diff = Store.Stakers.remove_existing (ctxt, rollup) staker in let* ctxt = modify_staker_count ctxt rollup Int32.pred in - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = if Commitment_hash.(node = lcc) then return ctxt else let* pred, ctxt = diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.ml index accc5a20cb4e3..0335f6d88b05e 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.ml @@ -26,8 +26,7 @@ open Sc_rollup_errors module Store = Storage.Sc_rollup -module Commitment = Sc_rollup_commitment_repr -module Commitment_hash = Commitment.Hash +module Commitment_hash = Sc_rollup_commitment_repr.Hash let originate ctxt ~kind ~boot_sector ~parameters_ty = Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) -> @@ -80,7 +79,7 @@ let parameters_type ctxt rollup = let+ ctxt, res = Store.Parameters_type.find ctxt rollup in (res, ctxt) -module Outbox = struct +module Outbox_aux = struct let level_index ctxt level = let max_active_levels = Constants_storage.sc_rollup_max_active_outbox_levels ctxt diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.mli b/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.mli index 14ad0e66eec4f..e69e4bb89041c 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.mli +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_storage.mli @@ -62,7 +62,7 @@ val parameters_type : (Script_repr.lazy_expr option * Raw_context.t) tzresult Lwt.t (** A module for managing state concerning a rollup's outbox. *) -module Outbox : sig +module Outbox_aux : sig (** [record_applied_message ctxt rollup level ~message_index] marks the message in the outbox of rollup [rollup] at level [level] and position [message_index] as processed. Returns the size diff resulting from diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_tick_repr.ml index 4485fa03e32f1..7359e5d320fdf 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_tick_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_tick_repr.ml @@ -24,13 +24,13 @@ (* *) (*****************************************************************************) -include Z +type t = Z.t -let initial = zero +let initial = Z.zero -let next = succ +let next = Z.succ -let pp = pp_print +let pp = Z.pp_print let encoding = Data_encoding.n @@ -45,16 +45,24 @@ let of_z x = x let of_number_of_ticks x = Z.of_int (Int32.to_int (Sc_rollup_repr.Number_of_ticks.to_int32 x)) -let ( <= ) = leq +let ( <= ) = Z.leq -let ( < ) = lt +let ( < ) = Z.lt -let ( >= ) = geq +let ( >= ) = Z.geq -let ( > ) = gt +let ( > ) = Z.gt -let ( = ) = equal +let ( = ) = Z.equal let ( <> ) x y = not (x = y) +let compare = Z.compare + +let equal = Z.equal + +let min = Z.min + +let max = Z.max + module Map = Map.Make (Z) diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollup_wasm.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollup_wasm.ml index 67d9c7e040abb..60cac7759cddf 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_wasm.ml @@ -103,15 +103,16 @@ module V2_0_0 = struct type nonrec proof = Context.proof proof - let proof_input_given p = p.given + let proof_input_given (p : proof) = p.given - let proof_input_requested p = p.requested + let proof_input_requested (p : proof) = p.requested - let proof_encoding = proof_encoding Context.proof_encoding + let proof_encoding : proof Data_encoding.t = + proof_encoding Context.proof_encoding - let proof_start_state p = Context.proof_before p.tree_proof + let proof_start_state (p : proof) = Context.proof_before p.tree_proof - let proof_stop_state p = + let proof_stop_state (p : proof) = match (p.given, p.requested) with | None, PS.No_input_required -> Some (Context.proof_after p.tree_proof) | None, _ -> None @@ -287,7 +288,7 @@ module V2_0_0 = struct in return (state, request) - let verify_proof proof = + let verify_proof (proof : proof) = let open Lwt_syntax in let* result = Context.verify_proof proof.tree_proof (step_transition proof.given) @@ -299,7 +300,7 @@ module V2_0_0 = struct type error += WASM_proof_production_failed - let produce_proof context input_given state = + let produce_proof context input_given state : (proof, error) result Lwt.t = let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) @@ -401,15 +402,18 @@ module V2_0_0 = struct (* Can't produce proof without full context*) Lwt.return None - let kinded_hash_to_state_hash = function + let[@coq_axiom_with_reason "Type error."] kinded_hash_to_state_hash = + function | `Value hash | `Node hash -> State_hash.hash_bytes [Context_hash.to_bytes hash] - let proof_before proof = + let[@coq_axiom_with_reason "Type error."] proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after + let[@coq_axiom_with_reason "Type error."] proof_after proof = + kinded_hash_to_state_hash proof.Context.Proof.after - let proof_encoding = Context.Proof_encoding.V1.Tree32.tree_proof_encoding + let[@coq_axiom_with_reason "Type error."] proof_encoding = + Context.Proof_encoding.V1.Tree32.tree_proof_encoding end) end diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollups.ml b/src/proto_014_PtKathma/lib_protocol/sc_rollups.ml index f8dc13c41824c..d142b61ac28f7 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollups.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollups.ml @@ -84,11 +84,11 @@ module Kind = struct | "wasm_2_0_0" -> Some Wasm_2_0_0 | _ -> None - let example_arith_pvm = - (module Sc_rollup_arith.ProtocolImplementation : PVM.S) + let example_arith_pvm : (module PVM.S) = + (module (Sc_rollup_arith.ProtocolImplementation : PVM.S)) - let wasm_2_0_0_pvm = - (module Sc_rollup_wasm.V2_0_0.ProtocolImplementation : PVM.S) + let wasm_2_0_0_pvm : (module PVM.S) = + (module (Sc_rollup_wasm.V2_0_0.ProtocolImplementation : PVM.S)) let pvm_of = function | Example_arith -> example_arith_pvm @@ -122,7 +122,7 @@ end module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end type wrapped_proof = @@ -148,7 +148,7 @@ let wrapped_proof_module p = include P end : PVM_with_proof) -let wrapped_proof_encoding = +let[@coq_axiom_with_reason "Module Issues."] wrapped_proof_encoding = let open Data_encoding in let encoding = union @@ -165,13 +165,13 @@ let wrapped_proof_encoding = Sc_rollup_arith.ProtocolImplementation.proof) = pvm in - Some P.proof + Some P.proof_val | _ -> None) (fun proof -> let module P = struct include Sc_rollup_arith.ProtocolImplementation - let proof = proof + let proof_val = proof end in Arith_pvm_with_proof (module P)); case @@ -185,20 +185,20 @@ let wrapped_proof_encoding = Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof) = pvm in - Some P.proof + Some P.proof_val | _ -> None) (fun proof -> let module P = struct include Sc_rollup_wasm.V2_0_0.ProtocolImplementation - let proof = proof + let proof_val = proof end in Wasm_2_0_0_pvm_with_proof (module P)); ] in check_size Constants_repr.sc_max_wrapped_proof_binary_size encoding -let wrap_proof pvm_with_proof = +let[@coq_axiom_with_reason "Module Issues."] wrap_proof pvm_with_proof = let (module P : PVM_with_proof) = pvm_with_proof in match Kind.of_name P.name with | None -> Some (Unencodable pvm_with_proof) @@ -208,11 +208,11 @@ let wrap_proof pvm_with_proof = let module P_arith = struct include Sc_rollup_arith.ProtocolImplementation - let proof = arith_proof + let proof_val = arith_proof end in Arith_pvm_with_proof (module P_arith)) (Option.bind - (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof) + (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof_val) (fun bytes -> Data_encoding.Binary.of_bytes_opt Sc_rollup_arith.ProtocolImplementation.proof_encoding @@ -223,11 +223,11 @@ let wrap_proof pvm_with_proof = let module P_wasm2_0_0 = struct include Sc_rollup_wasm.V2_0_0.ProtocolImplementation - let proof = wasm_proof + let proof_val = wasm_proof end in Wasm_2_0_0_pvm_with_proof (module P_wasm2_0_0)) (Option.bind - (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof) + (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof_val) (fun bytes -> Data_encoding.Binary.of_bytes_opt Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof_encoding diff --git a/src/proto_014_PtKathma/lib_protocol/sc_rollups.mli b/src/proto_014_PtKathma/lib_protocol/sc_rollups.mli index 81ec833da0ab9..3684ff07ab392 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollups.mli +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollups.mli @@ -87,7 +87,7 @@ end module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end (** A wrapper for first-class modules [(module PVM_with_proof)]. We need diff --git a/src/proto_014_PtKathma/lib_protocol/script_big_map.ml b/src/proto_014_PtKathma/lib_protocol/script_big_map.ml index 44369f61a1fd5..7ed08fb4359b3 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_big_map.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_big_map.ml @@ -29,11 +29,11 @@ open Script_typed_ir open Script_ir_translator -let empty key_type value_type = +let empty key_type value_type : ('a, 'b) big_map = Big_map { id = None; - diff = {map = Big_map_overlay.empty; size = 0}; + diff = {map = Big_map_overlay.empty; size = 0} [@coq_type_annotation]; key_type; value_type; } @@ -48,37 +48,41 @@ let mem ctxt key (Big_map {id; diff; key_type; _}) = | Some (_, None), _ -> return (false, ctxt) | Some (_, Some _), _ -> return (true, ctxt) -let get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = - match (Big_map_overlay.find key diff.map, id) with - | Some (_, x), _ -> return (x, ctxt) - | None, None -> return (None, ctxt) - | None, Some id -> ( - Alpha_context.Big_map.get_opt ctxt id key >>=? function - | ctxt, None -> return (None, ctxt) - | ctxt, Some value -> - parse_data - ctxt - ~legacy:true - ~allow_forged:true - value_type - (Micheline.root value) - >|=? fun (x, ctxt) -> (Some x, ctxt)) +let get_by_hash ctxt key big_map = + match[@coq_match_gadt] big_map with + | Big_map {id; diff; value_type; _} -> ( + match (Big_map_overlay.find key diff.map, id) with + | Some (_, x), _ -> return (x, ctxt) + | None, None -> return (None, ctxt) + | None, Some id -> ( + Alpha_context.Big_map.get_opt ctxt id key >>=? function + | ctxt, None -> return (None, ctxt) + | ctxt, Some value -> + parse_data + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >|=? fun (x, ctxt) -> (Some x, ctxt))) let get ctxt key (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - get_by_hash ctxt key_hash map + (get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map -let update_by_hash key_hash key value (Big_map map) = - let contains = Big_map_overlay.mem key_hash map.diff.map in - Big_map - { - map with - diff = +let update_by_hash key_hash key value big_map = + match[@coq_match_gadt] big_map with + | Big_map map -> + let contains = Big_map_overlay.mem key_hash map.diff.map in + Big_map { - map = Big_map_overlay.add key_hash (key, value) map.diff.map; - size = (if contains then map.diff.size else map.diff.size + 1); - }; - } + map with + diff = + { + map = Big_map_overlay.add key_hash (key, value) map.diff.map; + size = (if contains then map.diff.size else map.diff.size + 1); + }; + } let update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> @@ -88,5 +92,5 @@ let update ctxt key value (Big_map {key_type; _} as map) = let get_and_update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> let new_map = update_by_hash key_hash key value map in - get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) -> - return ((old_value, new_map), ctxt) + (get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map + >>=? fun (old_value, ctxt) -> return ((old_value, new_map), ctxt) diff --git a/src/proto_014_PtKathma/lib_protocol/script_comparable.ml b/src/proto_014_PtKathma/lib_protocol/script_comparable.ml index d570ef9bda766..391495985f44a 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_comparable.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_comparable.ml @@ -42,46 +42,63 @@ type compare_comparable_cont = -> compare_comparable_cont | Compare_comparable_return : compare_comparable_cont -let compare_comparable : type a. a comparable_ty -> a -> a -> int = - let rec compare_comparable : +module Compare_comparable = struct + let[@coq_struct "kind_value"] rec compare_comparable : type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int = fun kind k x y -> - match (kind, x, y) with - | Unit_t, (), () -> (apply [@tailcall]) 0 k + match[@coq_match_gadt] [@coq_match_with_default] (kind, x, y) with + | Unit_t, _, _ -> (apply [@tailcall]) 0 k | Never_t, _, _ -> . - | Signature_t, x, y -> (apply [@tailcall]) (Script_signature.compare x y) k - | String_t, x, y -> (apply [@tailcall]) (Script_string.compare x y) k - | Bool_t, x, y -> (apply [@tailcall]) (Compare.Bool.compare x y) k - | Mutez_t, x, y -> (apply [@tailcall]) (Tez.compare x y) k - | Key_hash_t, x, y -> + | Signature_t, (x : signature), (y : signature) -> + (apply [@tailcall]) (Script_signature.compare x y) k + | String_t, (x : Script_string.t), (y : Script_string.t) -> + (apply [@tailcall]) (Script_string.compare x y) k + | Bool_t, (x : bool), (y : bool) -> + (apply [@tailcall]) (Compare.Bool.compare x y) k + | Mutez_t, (x : Tez.t), (y : Tez.t) -> + (apply [@tailcall]) (Tez.compare x y) k + | Key_hash_t, (x : public_key_hash), (y : public_key_hash) -> (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k - | Key_t, x, y -> (apply [@tailcall]) (Signature.Public_key.compare x y) k - | Int_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k - | Nat_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k - | Timestamp_t, x, y -> (apply [@tailcall]) (Script_timestamp.compare x y) k - | Address_t, x, y -> (apply [@tailcall]) (compare_address x y) k - | Tx_rollup_l2_address_t, x, y -> + | Key_t, (x : public_key), (y : public_key) -> + (apply [@tailcall]) (Signature.Public_key.compare x y) k + | Int_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) (Script_int.compare x y) k + | Nat_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) (Script_int.compare x y) k + | Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t) -> + (apply [@tailcall]) (Script_timestamp.compare x y) k + | Address_t, (x : address), (y : address) -> + (apply [@tailcall]) (compare_address x y) k + | ( Tx_rollup_l2_address_t, + (x : tx_rollup_l2_address), + (y : tx_rollup_l2_address) ) -> (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k - | Bytes_t, x, y -> (apply [@tailcall]) (Compare.Bytes.compare x y) k - | Chain_id_t, x, y -> (apply [@tailcall]) (Script_chain_id.compare x y) k - | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) -> + | Bytes_t, (x : bytes), (y : bytes) -> + (apply [@tailcall]) (Compare.Bytes.compare x y) k + | Chain_id_t, (x : Script_chain_id.t), (y : Script_chain_id.t) -> + (apply [@tailcall]) (Script_chain_id.compare x y) k + | Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _) -> + let lx, rx = x in + let ly, ry = y in (compare_comparable [@tailcall]) tl (Compare_comparable (tr, rx, ry, k)) lx ly - | Union_t (tl, _, _, YesYes), L x, L y -> - (compare_comparable [@tailcall]) tl k x y - | Union_t _, L _, R _ -> -1 - | Union_t _, R _, L _ -> 1 - | Union_t (_, tr, _, YesYes), R x, R y -> - (compare_comparable [@tailcall]) tr k x y - | Option_t _, None, None -> (apply [@tailcall]) 0 k - | Option_t _, None, Some _ -> -1 - | Option_t _, Some _, None -> 1 - | Option_t (t, _, Yes), Some x, Some y -> - (compare_comparable [@tailcall]) t k x y - and apply ret k = + | Union_t (tl, tr, _, YesYes), (x : (_, _) union), (y : (_, _) union) -> ( + match (x, y) with + | L x, L y -> (compare_comparable [@tailcall]) tl k x y + | L _, R _ -> -1 + | R _, L _ -> 1 + | R x, R y -> (compare_comparable [@tailcall]) tr k x y) + | Option_t (t, _, _), (x : _ option), (y : _ option) -> ( + match (x, y) with + | None, None -> (apply [@tailcall]) 0 k + | None, Some _ -> -1 + | Some _, None -> 1 + | Some x, Some y -> (compare_comparable [@tailcall]) t k x y) + + and[@coq_mutual_as_notation] apply ret k = match (ret, k) with | 0, Compare_comparable (ty, x, y, k) -> (compare_comparable [@tailcall]) ty k x y @@ -89,6 +106,7 @@ let compare_comparable : type a. a comparable_ty -> a -> a -> int = | ret, _ -> (* ret <> 0, we perform an early exit *) if Compare.Int.(ret > 0) then 1 else -1 - in - fun t -> compare_comparable t Compare_comparable_return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] +end + +let compare_comparable : type a. a comparable_ty -> a -> a -> int = + fun t -> Compare_comparable.compare_comparable t Compare_comparable_return diff --git a/src/proto_014_PtKathma/lib_protocol/script_int.ml b/src/proto_014_PtKathma/lib_protocol/script_int.ml index a2ef0ebc257e9..5d06c29b734ed 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_int.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_int.ml @@ -35,7 +35,7 @@ type z = Integer_tag having to deconstruct to and reconstruct from `Z.t`. *) type 't repr = Z.t -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] let compare (Num_tag x) (Num_tag y) = Z.compare x y diff --git a/src/proto_014_PtKathma/lib_protocol/script_int.mli b/src/proto_014_PtKathma/lib_protocol/script_int.mli index 1dbb5425330dc..7abe7e93c5697 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_int.mli +++ b/src/proto_014_PtKathma/lib_protocol/script_int.mli @@ -34,7 +34,7 @@ type 't repr [@@coq_phantom] (** [num] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] (** Flag for natural numbers. *) type n = Natural_tag diff --git a/src/proto_014_PtKathma/lib_protocol/script_interpreter.ml b/src/proto_014_PtKathma/lib_protocol/script_interpreter.ml index deeddb0b3e902..5464079c178c4 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_interpreter.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_interpreter.ml @@ -234,6 +234,18 @@ let () = *) +let ifailwith : ifailwith_type = + { + ifailwith = + (fun logger (ctxt, _) gas kloc tv accu -> + let v = accu in + let ctxt = update_context gas ctxt in + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); + } + (* Evaluation of continuations @@ -251,19 +263,19 @@ let () = evaluation is logged. *) -let rec kmap_exit : +let[@coq_mutual_as_notation] rec kmap_exit : type a b c e f m n o. (a, b, c, e, f, m, n, o) kmap_exit_type = fun instrument g gas body xs ty ys yk ks accu stack -> let ys = Script_map.update yk (Some accu) ys in let ks = instrument @@ KMap_enter_body (body, xs, ys, ty, ks) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and kmap_enter : type a b c d f i j k. (a, b, c, d, f, i, j, k) kmap_enter_type +and[@coq_mutual_as_notation] kmap_enter : type a b c d f i j k. (a, b, c, d, f, i, j, k) kmap_enter_type = fun instrument g gas body xs ty ys ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack) | (xk, xv) :: xs -> let ks = instrument @@ KMap_exit_body (body, xs, ys, xk, ty, ks) in @@ -272,16 +284,16 @@ and kmap_enter : type a b c d f i j k. (a, b, c, d, f, i, j, k) kmap_enter_type (step [@ocaml.tailcall]) g gas body ks res stack [@@inline] -and klist_exit : type a b c d e i j. (a, b, c, d, e, i, j) klist_exit_type = +and[@coq_mutual_as_notation] klist_exit : type a b c d e i j. (a, b, c, d, e, i, j) klist_exit_type = fun instrument g gas body xs ys ty len ks accu stack -> let ks = instrument @@ KList_enter_body (body, xs, accu :: ys, ty, len, ks) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and klist_enter : type a b c d e f j. (a, b, c, d, e, f, j) klist_enter_type = +and[@coq_mutual_as_notation] klist_enter : type a b c d e f j. (a, b, c, d, e, f, j) klist_enter_type = fun instrument g gas body xs ys ty len ks' accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> let ys = {elements = List.rev ys; length = len} in (next [@ocaml.tailcall]) g gas ks' ys (accu, stack) @@ -290,31 +302,33 @@ and klist_enter : type a b c d e f j. (a, b, c, d, e, f, j) klist_enter_type = (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type - = +and[@coq_mutual_as_notation] kloop_in_left : + type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = fun g gas ks0 ki ks' accu stack -> - match accu with + match[@coq_type_annotation] accu with | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack | R v -> (next [@ocaml.tailcall]) g gas ks' v stack [@@inline] -and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = +and[@coq_mutual_as_notation] kloop_in : + type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> let accu', stack' = stack in - if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' + if [@coq_type_annotation] accu then + (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] -and kiter : type a b s r f c. (a, b, s, r, f, c) kiter_type = +and[@coq_mutual_as_notation] kiter : type a b s r f c. (a, b, s, r, f, c) kiter_type = fun instrument g gas body ty xs ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks accu stack | x :: xs -> let ks = instrument @@ KIter (body, ty, xs, ks) in (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and next : +and[@coq_struct "gas"] next : type a s r f. outdated_context * step_constants -> local_gas_counter -> @@ -322,25 +336,26 @@ and next : a -> s -> (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = - fun ((ctxt, _) as g) gas ks0 accu stack -> + fun g gas ks0 accu stack -> + let ctxt, _ = g in match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match ks0 with - | KLog (ks, sty, logger) -> + match[@coq_match_gadt] (ks0, accu, stack) with + | KLog (ks, sty, logger), _, _ -> (klog [@ocaml.tailcall]) logger g gas sty ks0 ks accu stack - | KNil -> Lwt.return (Ok (accu, stack, ctxt, gas)) - | KCons (k, ks) -> (step [@ocaml.tailcall]) g gas k ks accu stack - | KLoop_in (ki, ks') -> + | KNil , (accu : r), (stack : f) -> Lwt.return (Ok (accu, stack, ctxt, gas)) + | KCons (k, ks), _, _ -> (step [@ocaml.tailcall]) g gas k ks accu stack + | KLoop_in (ki, ks'), (accu : bool), (stack : _ * _) -> (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', _, ks) -> (next [@ocaml.tailcall]) g gas ks accu stack' - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | KReturn (stack', _, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack' + | KMap_head (f, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks (f accu) stack + | KLoop_in_left (ki, ks'), (accu : _ union), _ -> (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, _, ks) -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) - | KIter (body, ty, xs, ks) -> + | KUndip (x, _, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) + | KIter (body, ty, xs, ks), _, _ -> (kiter [@ocaml.tailcall]) id g gas body ty xs ks accu stack - | KList_enter_body (body, xs, ys, ty, len, ks) -> + | KList_enter_body (body, xs, ys, ty, len, ks), _, _ -> (klist_enter [@ocaml.tailcall]) id g @@ -353,7 +368,7 @@ and next : ks accu stack - | KList_exit_body (body, xs, ys, ty, len, ks) -> + | KList_exit_body (body, xs, ys, ty, len, ks), _, (stack : _ * _) -> (klist_exit [@ocaml.tailcall]) id g @@ -366,11 +381,11 @@ and next : ks accu stack - | KMap_enter_body (body, xs, ys, ty, ks) -> + | KMap_enter_body (body, xs, ys, ty, ks), _, _ -> (kmap_enter [@ocaml.tailcall]) id g gas body xs ty ys ks accu stack - | KMap_exit_body (body, xs, ys, yk, ty, ks) -> + | KMap_exit_body (body, xs, ys, yk, ty, ks), _, (stack : _ * _) -> (kmap_exit [@ocaml.tailcall]) id g gas body xs ty ys yk ks accu stack - | KView_exit (orig_step_constants, ks) -> + | KView_exit (orig_step_constants, ks), _, _ -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks accu stack) @@ -387,38 +402,38 @@ and next : instructions. *) -and ilist_map : +and[@coq_mutual_as_notation] ilist_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) ilist_map_type = fun instrument g gas body k ks ty accu stack -> let xs = accu.elements in - let ys = [] in + let ys = (([] [@coq_type_annotation]) : f list) in let len = accu.length in let ks = instrument @@ KList_enter_body (body, xs, ys, ty, len, KCons (k, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and ilist_iter : +and[@coq_mutual_as_notation] ilist_iter : type a b c d e f g cmp. (a, b, c, d, e, f, g, cmp) ilist_iter_type = fun instrument g gas body ty k ks accu stack -> let xs = accu.elements in let ks = instrument @@ KIter (body, ty, xs, KCons (k, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = +and[@coq_mutual_as_notation] iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = fun instrument g gas body ty k ks accu stack -> let set = accu in let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in let ks = instrument @@ KIter (body, ty, l, KCons (k, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imap_map : +and[@coq_mutual_as_notation] imap_map : type a b c d e f g h i j. (a, b, c, d, e, f, g, h, i, j) imap_map_type = fun instrument g gas body k ks ty accu stack -> let map = accu in @@ -426,64 +441,52 @@ and imap_map : let ys = Script_map.empty_from map in let ks = instrument @@ KMap_enter_body (body, xs, ys, ty, KCons (k, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imap_iter : +and[@coq_mutual_as_notation] imap_iter : type a b c d e f g h cmp. (a, b, c, d, e, f, g, h, cmp) imap_iter_type = fun instrument g gas body ty k ks accu stack -> let map = accu in let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in let ks = instrument @@ KIter (body, ty, l, KCons (k, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = +and[@coq_mutual_as_notation] imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas loc k ks accu stack -> let x = accu in let y, stack = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (loc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = +and[@coq_mutual_as_notation] imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas loc k ks accu stack -> let y = accu in let x, stack = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (loc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = +and[@coq_mutual_as_notation] ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas loc k ks accu stack -> let x = accu and y, stack = stack in - match Script_int.shift_left_n x y with + match[@coq_type_annotation] Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (loc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack -and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = +and[@coq_mutual_as_notation] ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas loc k ks accu stack -> let x = accu and y, stack = stack in - match Script_int.shift_right_n x y with + match[@coq_type_annotation] Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (loc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack -and ifailwith : ifailwith_type = - { - ifailwith = - (fun logger (ctxt, _) gas kloc tv accu -> - let v = accu in - let ctxt = update_context gas ctxt in - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) - >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); - } - -and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = +and[@coq_mutual_as_notation] iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun instrument logger g gas cont_sty k ks accu stack -> let arg = accu and code, stack = stack in let (Lam (code, _)) = code in @@ -494,7 +497,7 @@ and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = Script_interpreter_logging.log_kinstr logger code.kbef code.kinstr in let ks = instrument @@ KReturn (stack, cont_sty, KCons (k, ks)) in - (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell) + (((step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell))[@coq_type_annotation]) and iview : type a b c d e f i o. (a, b, c, d, e, f, i, o) iview_type = fun instrument @@ -585,31 +588,34 @@ and iview : type a b c d e f i o. (a, b, c, d, e, f, i, o) iview_type = (input, storage) (EmptyCell, EmptyCell)))) -and step : type a s b t r f. (a, s, b, t, r, f) step_type = +and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = fun ((ctxt, sc) as g) gas i ks accu stack -> match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match i with - | ILog (_, sty, event, logger, k) -> + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | ILog (_, sty, event, logger, k), _, _ -> (log [@ocaml.tailcall]) (logger, event) sty g gas k ks accu stack - | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack + | IHalt _, _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack (* stack ops *) - | IDrop (_, k) -> + | IDrop (_, k), _, (stack : _ * _) -> let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) - | ISwap (_, k) -> + | IDup (_, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) + | ISwap (_, k), _, (stack : _ * _) -> let top, stack = stack in (step [@ocaml.tailcall]) g gas k ks top (accu, stack) - | IConst (_, _ty, v, k) -> + | IConst (_, _ty, v, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) (* options *) - | ICons_some (_, k) -> + | ICons_some (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (Some accu) stack - | ICons_none (_, _ty, k) -> - (step [@ocaml.tailcall]) g gas k ks None (accu, stack) - | IIf_none {branch_if_none; branch_if_some; k; _} -> ( + | ICons_none (_, _ty, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) (accu, stack) + | IIf_none {branch_if_none; branch_if_some; k; _} , + (accu : _ option), + (stack : _ * _) -> ( match accu with | None -> let accu, stack = stack in @@ -628,31 +634,40 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) v stack) - | IOpt_map {body; k; loc = _} -> ( + | IOpt_map {body; k; loc = _}, (accu : _ option), _ -> ( match accu with - | None -> (step [@ocaml.tailcall]) g gas k ks None stack + | None -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack | Some v -> - let ks' = KMap_head (Option.some, KCons (k, ks)) in + let ks' = + KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks)) + in (step [@ocaml.tailcall]) g gas body ks' v stack) (* pairs *) - | ICons_pair (_, k) -> + | ICons_pair (_, k), _, (stack : _ * _) -> let b, stack = stack in (step [@ocaml.tailcall]) g gas k ks (accu, b) stack - | IUnpair (_, k) -> + | IUnpair (_, k), (accu : _ * _), _ -> let a, b = accu in (step [@ocaml.tailcall]) g gas k ks a (b, stack) - | ICar (_, k) -> + | ICar (_, k), (accu : _ * _), _ -> let a, _ = accu in (step [@ocaml.tailcall]) g gas k ks a stack - | ICdr (_, k) -> + | ICdr (_, k), (accu : _ * _), _ -> let _, b = accu in (step [@ocaml.tailcall]) g gas k ks b stack (* unions *) - | ICons_left (_, _tyb, k) -> - (step [@ocaml.tailcall]) g gas k ks (L accu) stack - | ICons_right (_, _tya, k) -> - (step [@ocaml.tailcall]) g gas k ks (R accu) stack - | IIf_left {branch_if_left; branch_if_right; k; _} -> ( + | ICons_left (_, _tyb, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks (L accu [@coq_type_annotation]) stack + | ICons_right (_, _tya, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks (R accu [@coq_type_annotation]) stack + | IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _ -> ( match accu with | L v -> (step [@ocaml.tailcall]) @@ -671,15 +686,23 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = v stack) (* lists *) - | ICons_list (_, k) -> + | ICons_list (_, k), _, (stack : _ * _) -> let tl, stack = stack in let accu = Script_list.cons accu tl in (step [@ocaml.tailcall]) g gas k ks accu stack - | INil (_, _ty, k) -> + | INil (_, _ty, k), _, _ -> let stack = (accu, stack) in let accu = Script_list.empty in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> ( + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_implicit "E" "__INil_'b"]) + stack + | ( IIf_cons {branch_if_cons; branch_if_nil; k; _}, + (accu : _ boxed_list), + (stack : _ * _) ) -> ( match accu.elements with | [] -> let accu, stack = stack in @@ -699,88 +722,100 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) hd (tl, stack)) - | IList_map (_, body, ty, k) -> - (ilist_map [@ocaml.tailcall]) id g gas body k ks ty accu stack - | IList_size (_, k) -> + | IList_map (_, body, ty, k), (accu : _ boxed_list), (stack : _ * _) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"]) id g gas body k ks ty accu stack + | IList_size (_, k), (accu : _ boxed_list), _ -> let list = accu in let len = Script_int.(abs (of_int list.length)) in (step [@ocaml.tailcall]) g gas k ks len stack - | IList_iter (_, ty, body, k) -> + | IList_iter (_, ty, body, k), (accu : _ boxed_list), (stack : _ * _) -> (ilist_iter [@ocaml.tailcall]) id g gas body ty k ks accu stack (* sets *) - | IEmpty_set (_, ty, k) -> - let res = Script_set.empty ty in + | IEmpty_set (_, ty, k), _, _ -> + let res = (Script_set.empty [@coq_type_annotation]) ty in let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_iter (_, ty, body, k) -> + | ISet_iter (_, ty, body, k), (accu : _ set), (stack : _ * _) -> (iset_iter [@ocaml.tailcall]) id g gas body ty k ks accu stack - | ISet_mem (_, k) -> + | ISet_mem (_, k), _, (stack : _ * _) -> let set, stack = stack in let res = Script_set.mem accu set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_update (_, k) -> + | ISet_update (_, k), _, (stack : _ * (_ * _)) -> let presence, (set, stack) = stack in let res = Script_set.update accu presence set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_size (_, k) -> + | ISet_size (_, k), (accu : _ set), _ -> let res = Script_set.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* maps *) - | IEmpty_map (_, kty, _vty, k) -> + | IEmpty_map (_, kty, _vty, k), _, _ -> let res = Script_map.empty kty and stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_map (_, ty, body, k) -> - (imap_map [@ocaml.tailcall]) id g gas body k ks ty accu stack - | IMap_iter (_, kvty, body, k) -> + | IMap_map (_, ty, body, k), (accu : _ map), (stack : _ * _) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"]) id g gas body k ks ty accu stack + | IMap_iter (_, kvty, body, k), (accu : _ map), (stack : _ * _) -> (imap_iter [@ocaml.tailcall]) id g gas body kvty k ks accu stack - | IMap_mem (_, k) -> + | IMap_mem (_, k), _, (stack : _ * _) -> let map, stack = stack in let res = Script_map.mem accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get (_, k) -> + | IMap_get (_, k), _, (stack : _ * _) -> let map, stack = stack in let res = Script_map.get accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_update (_, k) -> + | IMap_update (_, k), _, (stack : _ * (_ * _)) -> let v, (map, stack) = stack in let key = accu in let res = Script_map.update key v map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get_and_update (_, k) -> + | IMap_get_and_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let v, (map, rest) = stack in let map' = Script_map.update key v map in let v' = Script_map.get key map in (step [@ocaml.tailcall]) g gas k ks v' (map', rest) - | IMap_size (_, k) -> + | IMap_size (_, k), (accu : _ map), _ -> let res = Script_map.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* Big map operations *) - | IEmpty_big_map (_, tk, tv, k) -> - let ebm = Script_big_map.empty tk tv in + | IEmpty_big_map (_, tk, tv, k), _, _ -> + let ebm = + (Script_big_map.empty + [@coq_implicit "a" "__IEmpty_big_map_'b"] + [@coq_implicit "b" "__IEmpty_big_map_'c"]) + tk + tv + in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) - | IBig_map_mem (_, k) -> + | IBig_map_mem (_, k), _, (stack : _ * _) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.mem ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_get (_, k) -> + | IBig_map_get (_, k), _, (stack : _ * _) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.get ctxt key map ) >>=? fun (res, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_update (_, k) -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (res [@coq_type_annotation]) + stack + | IBig_map_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let maybe_value, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.update ctxt key maybe_value map ) >>=? fun (big_map, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack - | IBig_map_get_and_update (_, k) -> + | IBig_map_get_and_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let v, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> @@ -788,33 +823,39 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = >>=? fun ((v', map'), ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack) (* timestamp operations *) - | IAdd_seconds_to_timestamp (_, k) -> + | ( IAdd_seconds_to_timestamp (_, k), + (accu : _ Script_int.num), + (stack : _ * _) ) -> let n = accu in let t, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | IAdd_timestamp_to_seconds (_, k) -> + | ( IAdd_timestamp_to_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let n, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | ISub_timestamp_seconds (_, k) -> + | ( ISub_timestamp_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let s, stack = stack in let result = Script_timestamp.sub_delta t s in (step [@ocaml.tailcall]) g gas k ks result stack - | IDiff_timestamps (_, k) -> + | IDiff_timestamps (_, k), (accu : Script_timestamp.t), (stack : _ * _) -> let t1 = accu in let t2, stack = stack in let result = Script_timestamp.diff t1 t2 in (step [@ocaml.tailcall]) g gas k ks result stack (* string operations *) - | IConcat_string_pair (_, k) -> + | IConcat_string_pair (_, k), (accu : Script_string.t), (stack : _ * _) -> let x = accu in let y, stack = stack in let s = Script_string.concat_pair x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_string (_, k) -> + | IConcat_string (_, k), (accu : _ boxed_list), _ -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -826,8 +867,11 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_string (_, k) -> - let offset = accu and length, (s, stack) = stack in + | ( ISlice_string (_, k), + (accu : _ Script_int.num), + (stack : _ * (Script_string.t * _)) ) -> + let offset = accu in + let length, (s, stack) = stack in let s_length = Z.of_int (Script_string.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -835,18 +879,25 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IString_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | IString_size (_, k), (accu : Script_string.t), _ -> let s = accu in let result = Script_int.(abs (of_int (Script_string.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* bytes operations *) - | IConcat_bytes_pair (_, k) -> + | IConcat_bytes_pair (_, k), (accu : bytes), (stack : _ * _) -> let x = accu in let y, stack = stack in let s = Bytes.cat x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_bytes (_, k) -> + | IConcat_bytes (_, k), (accu : _ boxed_list), _ -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -858,8 +909,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Bytes.concat Bytes.empty ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_bytes (_, k) -> - let offset = accu and length, (s, stack) = stack in + | ISlice_bytes (_, k), (accu : _ Script_int.num), (stack : _ * (_ * _)) -> + let offset = accu in + let length, (s, stack) = stack in let s_length = Z.of_int (Bytes.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -867,85 +919,100 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IBytes_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | IBytes_size (_, k), (accu : bytes), _ -> let s = accu in let result = Script_int.(abs (of_int (Bytes.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* currency operations *) - | IAdd_tez (_, k) -> + | IAdd_tez (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in Tez.(x +? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez (_, k) -> + | ISub_tez (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in let res = Tez.sub_opt x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez_legacy (_, k) -> + | ISub_tez_legacy (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_teznat (loc, k) -> imul_teznat None g gas loc k ks accu stack - | IMul_nattez (loc, k) -> imul_nattez None g gas loc k ks accu stack + | IMul_teznat (loc, k), (accu : Tez.t), (stack : _ Script_int.num * _) + -> imul_teznat None g gas loc k ks accu stack + | IMul_nattez (loc, k), (accu : _ Script_int.num), (stack : Tez.t * _) + -> imul_nattez None g gas loc k ks accu stack (* boolean operations *) - | IOr (_, k) -> + | IOr (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x || y) stack - | IAnd (_, k) -> + | IAnd (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x && y) stack - | IXor (_, k) -> + | IXor (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in let res = Compare.Bool.(x <> y) in (step [@ocaml.tailcall]) g gas k ks res stack - | INot (_, k) -> + | INot (_, k), (accu : bool), _ -> let x = accu in (step [@ocaml.tailcall]) g gas k ks (not x) stack (* integer operations *) - | IIs_nat (_, k) -> + | IIs_nat (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.is_nat x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAbs_int (_, k) -> + | IAbs_int (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.abs x in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_nat (_, k) -> + | IInt_nat (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.int x in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg (_, k) -> + | INeg (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.neg x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_int (_, k) -> - let x = accu and y, stack = stack in + | IAdd_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.add x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_nat (_, k) -> - let x = accu and y, stack = stack in + | IAdd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.add_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_int (_, k) -> - let x = accu and y, stack = stack in + | ISub_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.sub x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_int (_, k) -> - let x = accu and y, stack = stack in + | IMul_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_nat (_, k) -> - let x = accu and y, stack = stack in + | IMul_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.mul_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_teznat (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_teznat (_, k), (accu : Tez.t), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let x = Script_int.of_int64 (Tez.to_mutez x) in let result = match Script_int.ediv x y with @@ -961,8 +1028,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | _ -> assert false) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_tez (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_tez (_, k), (accu : Tez.t), (stack : _ * _) -> + let x = accu in + let y, stack = stack in 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 let result = @@ -977,38 +1045,51 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some r -> Some (q, r))) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_int (_, k) -> - let x = accu and y, stack = stack in + | ( IEdiv_int (_, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + let x = accu in + let y, stack = stack in let res = Script_int.ediv x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_nat (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (loc, k) -> ilsl_nat None g gas loc k ks accu stack - | ILsr_nat (loc, k) -> ilsr_nat None g gas loc k ks accu stack - | IOr_nat (_, k) -> + | ILsl_nat (loc, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) -> ilsl_nat None g gas loc k ks accu stack + | ILsr_nat (loc, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) -> ilsr_nat None g gas loc k ks accu stack + | IOr_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> let x = accu and y, stack = stack in let res = Script_int.logor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_nat (_, k) -> - let x = accu and y, stack = stack in + | IAnd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_int_nat (_, k) -> - let x = accu and y, stack = stack in + | IAnd_int_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IXor_nat (_, k) -> - let x = accu and y, stack = stack in + | IXor_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logxor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | INot_int (_, k) -> + | INot_int (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.lognot x in (step [@ocaml.tailcall]) g gas k ks res stack (* control *) - | IIf {branch_if_true; branch_if_false; k; _} -> + | ( IIf {branch_if_true; branch_if_false; k; _}, + (accu : bool), + (stack : _ * _) ) -> let res, stack = stack in if accu then (step [@ocaml.tailcall]) @@ -1026,30 +1107,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) res stack - | ILoop (_, body, k) -> + | ILoop (_, body, k), _, _ -> let ks = KLoop_in (body, KCons (k, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | ILoop_left (_, bl, br), _, _ -> let ks = KLoop_in_left (bl, KCons (br, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | IDip (_, b, ty, k) -> + | IDip (_, b, ty, k), _, (stack : _ * _) -> let ign = accu in let ks = KUndip (ign, ty, KCons (k, ks)) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas b ks accu stack - | IExec (_, sty, k) -> iexec id None g gas sty k ks accu stack - | IApply (_, capture_ty, k) -> + | IExec (_, sty, k), _, (stack : _ lambda * _) -> + iexec id None g gas sty k ks accu stack + | IApply (_, capture_ty, k), _, (stack : _ lambda * _) -> let capture = accu in let lam, stack = stack in apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack - | ILambda (_, lam, k) -> + | ILambda (_, lam, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) - | IFailwith (kloc, tv) -> + | IFailwith (kloc, tv), _, _ -> let {ifailwith} = ifailwith in ifailwith None g gas kloc tv accu (* comparison *) - | ICompare (_, ty, k) -> + | ICompare (_, ty, k), _, (stack : _ * _) -> let a = accu in let b, stack = stack in let r = @@ -1057,53 +1139,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks r stack (* comparators *) - | IEq (_, k) -> + | IEq (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a = 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | INeq (_, k) -> + | INeq (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <> 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILt (_, k) -> + | ILt (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a < 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILe (_, k) -> + | ILe (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <= 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGt (_, k) -> + | IGt (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a > 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGe (_, k) -> + | IGe (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a >= 0) in (step [@ocaml.tailcall]) g gas k ks a stack (* packing *) - | IPack (_, ty, k) -> + | IPack (_, ty, k), _, _ -> let value = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.pack_data ctxt ty value ) >>=? fun (bytes, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack - | IUnpack (_, ty, k) -> + | IUnpack (_, ty, k), (accu : bytes), _ -> let bytes = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - unpack ctxt ~ty ~bytes ) + (unpack [@coq_type_annotation]) ctxt ~ty ~bytes ) >>=? fun (opt, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack - | IAddress (_, k) -> + | IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _ -> let (Typed_contract {address; _}) = accu in (step [@ocaml.tailcall]) g gas k ks address stack - | IContract (loc, t, entrypoint, k) -> ( + | IContract (loc, t, entrypoint, k), (accu : address), _ -> ( let addr = accu in let entrypoint_opt = if Entrypoint.is_default addr.entrypoint then Some entrypoint @@ -1123,15 +1205,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ITransfer_tokens (loc, k) -> + | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack) + | ITransfer_tokens (loc, k), _, (stack : _ * (_ typed_contract * _)) -> let p = accu in let amount, (Typed_contract {arg_ty; address}, stack) = stack in let {destination; entrypoint} = address in transfer (ctxt, sc) gas amount loc arg_ty p destination entrypoint >>=? fun (accu, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | IImplicit_account (_, k) -> + | IImplicit_account (_, k), (accu : public_key_hash), _ -> let key = accu in let arg_ty = unit_t in let address = @@ -1142,7 +1224,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let res = Typed_contract {arg_ty; address} in (step [@ocaml.tailcall]) g gas k ks res stack - | IView (_, view_signature, stack_ty, k) -> + | IView (_, view_signature, stack_ty, k), _, + (stack : address * _) -> (iview [@ocaml.tailcall]) id g @@ -1153,7 +1236,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = ks accu stack - | ICreate_contract {storage_type; code; k; loc = _} -> + | ICreate_contract {storage_type; code; k; loc = _}, (accu : public_key_hash option), + (stack : _ * (_ * _)) -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in let credit, (init, stack) = stack in @@ -1162,7 +1246,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let destination = Destination.Contract (Originated contract) in let stack = ({destination; entrypoint = Entrypoint.default}, stack) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | ISet_delegate (_, k) -> + | ISet_delegate (_, k), (accu : public_key_hash option), _ -> let delegate = accu in let operation = Delegation delegate in let ctxt = update_context gas ctxt in @@ -1171,18 +1255,25 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = Internal_operation {source = Contract.Originated sc.self; operation; nonce} in - let res = {piop; lazy_storage_diff = None} in + let res = + { + piop; + lazy_storage_diff = + (None [@coq_type_annotation] : Lazy_storage.diffs option); + } + in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBalance (_, k) -> + | IBalance (_, k), _, _ -> let ctxt = update_context gas ctxt in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack) - | ILevel (_, k) -> + | ILevel (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack) - | INow (_, k) -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) - | IMin_block_time (_, k) -> + | INow (_, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) + | IMin_block_time (_, k), _, _ -> let ctxt = update_context gas ctxt in let min_block_time = Alpha_context.Constants.minimal_block_delay ctxt @@ -1192,47 +1283,49 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let new_stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack - | ICheck_signature (_, k) -> - let key = accu and signature, (message, stack) = stack in + | ICheck_signature (_, k), (accu : public_key), (stack : _ * (_ * _)) -> + let key = accu in + let signature, (message, stack) = stack in let res = Script_signature.check key signature message in (step [@ocaml.tailcall]) g gas k ks res stack - | IHash_key (_, k) -> + | IHash_key (_, k), (accu : public_key), _ -> let key = accu in let res = Signature.Public_key.hash key in (step [@ocaml.tailcall]) g gas k ks res stack - | IBlake2b (_, k) -> + | IBlake2b (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.blake2b bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha256 (_, k) -> + | ISha256 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha512 (_, k) -> + | ISha512 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha512 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISource (_, k) -> + | ISource (_, k), _, _ -> let destination : Destination.t = Contract sc.payer in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISender (_, k) -> + | ISender (_, k), _, _ -> let destination : Destination.t = Contract sc.source in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf (_, ty, entrypoint, k) -> + | ISelf (_, ty, entrypoint, k), _, _ -> let destination : Destination.t = Contract (Originated sc.self) in let address = {destination; entrypoint} in let res = Typed_contract {arg_ty = ty; address} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf_address (_, k) -> + | ISelf_address (_, k), _, _ -> let destination : Destination.t = Contract (Originated sc.self) in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | IAmount (_, k) -> - let accu = sc.amount and stack = (accu, stack) in + | IAmount (_, k), _, _ -> + let stack = (accu, stack) in + let accu = sc.amount in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDig (_, _n, n', k) -> + | IDig (_, _n, n', k), _, _ -> let (accu, stack), x = interp_stack_prefix_preserving_operation (fun v stack -> (stack, v)) @@ -1240,9 +1333,10 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - let accu = x and stack = (accu, stack) in + let stack = ((accu, stack) [@coq_type_annotation]) in + let accu = x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDug (_, _n, n', k) -> + | IDug (_, _n, n', k), _, (stack : _ * _) -> let v = accu in let accu, stack = stack in let (accu, stack), () = @@ -1252,34 +1346,44 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IDipn (_, _n, n', b, k) -> - let accu, stack, restore_prefix = kundip n' accu stack k in + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_type_annotation]) + (stack [@coq_type_annotation]) + | IDipn (_, _n, n', b, k), _, _ -> + let accu, stack, restore_prefix = + (kundip [@coq_type_annotation]) n' accu stack k + in let ks = KCons (restore_prefix, ks) in (step [@ocaml.tailcall]) g gas b ks accu stack - | IDropn (_, _n, n', k) -> + | IDropn (_, _n, n', k), _, _ -> let stack = - let rec aux : + let[@coq_struct "w_value"] rec aux : type a s b t. (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness -> a -> s -> b * t = fun w accu stack -> - match w with - | KRest -> (accu, stack) - | KPrefix (_, _ty, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | KRest, (accu : b), (stack : t) -> (accu, stack) + | KPrefix (_, _ty, w), _, (stack : _ * _) -> let accu, stack = stack in aux w accu stack in - aux n' accu stack + (aux [@coq_type_annotation]) n' accu stack in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISapling_empty_state (_, memo_size, k) -> + | ISapling_empty_state (_, memo_size, k), _, _ -> let state = Sapling.empty_state ~memo_size () in (step [@ocaml.tailcall]) g gas k ks state (accu, stack) - | ISapling_verify_update (_, k) -> ( + | ( ISapling_verify_update (_, k), + (accu : Sapling.transaction), + (stack : _ * _) ) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1298,8 +1402,17 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (Script_int.of_int64 balance, state) ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ISapling_verify_update_deprecated (_, k) -> ( + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | ( ISapling_verify_update_deprecated (_, k), + (accu : Sapling_repr.legacy_transaction), + (stack : _ * _) ) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1314,175 +1427,228 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some (balance, state) -> let state = Some (Script_int.of_int64 balance, state) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | IChainId (_, k) -> - let accu = Script_chain_id.make sc.chain_id - and stack = (accu, stack) in + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | IChainId (_, k), _, _ -> + let stack = (accu, stack) in + let accu = Script_chain_id.make sc.chain_id in (step [@ocaml.tailcall]) g gas k ks accu stack - | INever _ -> ( match accu with _ -> .) - | IVoting_power (_, k) -> + | INever _, _, _ -> . + | IVoting_power (_, k), (accu : public_key_hash), _ -> let key_hash = accu in let ctxt = update_context gas ctxt in Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack - | ITotal_voting_power (_, k) -> + | ITotal_voting_power (_, k), _, _ -> let ctxt = update_context gas ctxt in Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks power (accu, stack) - | IKeccak (_, k) -> + | IKeccak (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.keccak256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha3 (_, k) -> + | ISha3 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | IAdd_bls12_381_g1 (_, k) -> - let x = accu and y, stack = stack in + | ( IAdd_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.G1.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_g2 (_, k) -> - let x = accu and y, stack = stack in + | ( IAdd_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.G2.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_fr (_, k) -> - let x = accu and y, stack = stack in + | ( IAdd_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g1 (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g2 (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr_z (_, k) -> - let x = accu and y, stack = stack in + | ( IMul_bls12_381_fr_z (_, k), + (accu : _ Script_int.num), + (stack : Script_bls.Fr.t * _) ) -> + let x = accu in + let y, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_bls12_381_z_fr (_, k) -> - let y = accu and x, stack = stack in + | ( IMul_bls12_381_z_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : _ Script_int.num * _) ) -> + let y = accu in + let x, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_bls12_381_fr (_, k) -> + | IInt_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _ -> let x = accu in let res = Script_int.of_zint (Script_bls.Fr.to_z x) in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg_bls12_381_g1 (_, k) -> + | INeg_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), _ -> let x = accu in let accu = Script_bls.G1.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_g2 (_, k) -> + | INeg_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), _ -> let x = accu in let accu = Script_bls.G2.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_fr (_, k) -> + | INeg_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _ -> let x = accu in let accu = Script_bls.Fr.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IPairing_check_bls12_381 (_, k) -> + | IPairing_check_bls12_381 (_, k), (accu : _ boxed_list), _ -> let pairs = accu in let check = Script_bls.pairing_check pairs.elements in (step [@ocaml.tailcall]) g gas k ks check stack - | IComb (_, _, witness, k) -> - let rec aux : + | IComb (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type a b s c d t. (a, b, s, c, d, t) comb_gadt_witness -> a * (b * s) -> c * (d * t) = fun witness stack -> - match (witness, stack) with - | Comb_one, stack -> stack - | Comb_succ witness', (a, tl) -> - let b, tl' = aux witness' tl in - ((a, b), tl') + match[@coq_match_gadt] (witness, stack) with + | Comb_one, (stack : c * (d * t)) -> stack + | Comb_succ witness', (stack : _ * _) -> + let a, tl = stack in + let b, tl' = (aux [@coq_type_annotation]) witness' tl in + ((((a, b), tl') [@coq_cast]) : c * (d * t)) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IUncomb (_, _, witness, k) -> - let rec aux : + | IUncomb (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type a b s c d t. (a, b, s, c, d, t) uncomb_gadt_witness -> a * (b * s) -> c * (d * t) = fun witness stack -> - match (witness, stack) with - | Uncomb_one, stack -> stack - | Uncomb_succ witness', ((a, b), tl) -> (a, aux witness' (b, tl)) + match[@coq_match_gadt] (witness, stack) with + | Uncomb_one, (stack : c * (d * t)) -> stack + | Uncomb_succ witness', (stack : (_ * _) * _) -> + let (a, b), tl = stack in + (((a, (aux [@coq_type_annotation]) witness' (b, tl)) + [@coq_cast]) + : c * (d * t)) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_get (_, _, witness, k) -> + | IComb_get (_, _, witness, k), _, _ -> let comb = accu in - let rec aux : + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_get_gadt_witness -> before -> after = fun witness comb -> - match (witness, comb) with - | Comb_get_zero, v -> v - | Comb_get_one, (a, _) -> a - | Comb_get_plus_two witness', (_, b) -> aux witness' b + match[@coq_match_gadt] (witness, comb) with + | Comb_get_zero, (v : after) -> v + | Comb_get_one, (comb : after * _) -> + let a, _ = comb in + a + | Comb_get_plus_two witness', (comb : _ * _) -> + let _, b = comb in + aux witness' b in - let accu = aux witness comb in + let accu = (aux [@coq_type_annotation]) witness comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_set (_, _, witness, k) -> - let value = accu and comb, stack = stack in - let rec aux : + | IComb_set (_, _, witness, k), _, (stack : _ * _) -> + let value = accu in + let comb, stack = stack in + let[@coq_struct "witness"] rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> value -> before -> after = fun witness value item -> - match (witness, item) with - | Comb_set_zero, _ -> value - | Comb_set_one, (_hd, tl) -> (value, tl) - | Comb_set_plus_two witness', (hd, tl) -> (hd, aux witness' value tl) + match[@coq_match_gadt] (witness, value, item) with + | Comb_set_zero, (value : after), _ -> value + | Comb_set_one, _, (item : _ * _) -> + let _hd, tl = item in + (((value, tl) [@coq_cast]) : after) + | Comb_set_plus_two witness', _, (item : _ * _) -> + let hd, tl = item in + (((hd, (aux [@coq_type_annotation]) witness' value tl) + [@coq_cast]) + : after) in - let accu = aux witness value comb in + let accu = (aux [@coq_type_annotation]) witness value comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup_n (_, _, witness, k) -> - let rec aux : + | IDup_n (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type a b before after. (a, b, before, after) dup_n_gadt_witness -> a * (b * before) -> after = fun witness stack -> - match (witness, stack) with - | Dup_n_zero, (a, _) -> a - | Dup_n_succ witness', (_, tl) -> aux witness' tl + match[@coq_match_gadt] (witness, stack) with + | Dup_n_zero, (stack : after * _) -> + let a, _ = stack in + a + | Dup_n_succ witness', (stack : _ * _) -> + let _, tl = stack in + aux witness' tl in let stack = (accu, stack) in - let accu = aux witness stack in + let accu = (aux [@coq_type_annotation]) witness stack in (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) - | ITicket (_, _, k) -> - let contents = accu and amount, stack = stack in + | ITicket (_, _, k), _, (stack : _ * _) -> + let contents = accu in + let amount, stack = stack in let ticketer = Contract.Originated sc.self in let accu = {ticketer; contents; amount} in (step [@ocaml.tailcall]) g gas k ks accu stack - | IRead_ticket (_, _, k) -> + | IRead_ticket (_, _, k), (accu : _ ticket), _ -> let {ticketer; contents; amount} = accu in let stack = (accu, stack) in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in let accu = (addr, (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISplit_ticket (_, k) -> - let ticket = accu and (amount_a, amount_b), stack = stack in + | ISplit_ticket (_, k), (accu : _ ticket), (stack : (_ * _) * _) -> + let ticket = accu in + let (amount_a, amount_b), stack = stack in let result = if Compare.Int.( @@ -1494,7 +1660,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IJoin_tickets (_, contents_ty, k) -> + | IJoin_tickets (_, contents_ty, k), (accu : _ ticket * _ ticket), _ -> let ticket_a, ticket_b = accu in let result = if @@ -1515,7 +1681,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IOpen_chest (_, k) -> + | ( IOpen_chest (_, k), + (accu : Script_timelock.chest_key), + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> let open Timelock in let chest_key = accu in let chest, (time_z, stack) = stack in @@ -1532,7 +1700,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Bogus_opening -> R true) in (step [@ocaml.tailcall]) g gas k ks accu stack - | IEmit {tag; ty = event_type; unparsed_ty; k; loc = _} -> + | IEmit {tag; ty = event_type; unparsed_ty; k; loc = _}, _, _ -> let event_data = accu in emit_event (ctxt, sc) gas ~event_type ~unparsed_ty ~tag ~event_data >>=? fun (accu, ctxt, gas) -> @@ -1563,7 +1731,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = that starts the evaluation. *) -and log : +and[@coq_axiom_with_reason "we ignore the logging operations"] log : type a s b t r f. logger * logging_event -> (a, s) stack_ty -> (a, s, b, t, r, f) step_type = fun (logger, event) sty ((ctxt, _) as g) gas k ks accu stack -> @@ -1774,7 +1942,7 @@ and log : | _ -> (step [@ocaml.tailcall]) g gas k ks accu stack [@@inline] -and klog : +and[@coq_axiom_with_reason "we ignore the logging operations"] klog : type a s r f. logger -> outdated_context * step_constants -> @@ -1921,7 +2089,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty) >>?= fun (res, ctxt) -> res >>?= fun Eq -> let parsed_arg : a = parsed_arg in - return (parsed_arg, ctxt)) + return ((parsed_arg [@coq_cast]), ctxt)) >>=? fun (entrypoint_arg, ctxt) -> return (construct entrypoint_arg, ctxt) type execution_result = { @@ -1943,18 +2111,18 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ~legacy:true ~allow_forged_in_storage:true | Some ex_script -> return (ex_script, ctxt)) - >>=? fun ( Ex_script - (Script - { - code_size; - code; - arg_type; - storage = old_storage; - storage_type; - entrypoints; - views; - }), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + code_size; + code; + arg_type; + storage = old_storage; + storage_type; + entrypoints; + views; + }), + ctxt ) -> Gas_monad.run ctxt (find_entrypoint @@ -1964,9 +2132,13 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal entrypoint) >>?= fun (r, ctxt) -> let self_contract = Contract.Originated step_constants.self in - record_trace (Bad_contract_parameter self_contract) r - >>?= fun (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) - -> + record_trace (Bad_contract_parameter self_contract) (r [@coq_type_annotation]) + >>?= fun [@coq_match_gadt] (Ex_ty_cstr + { + ty = entrypoint_ty; + construct; + original_type_expr = _; + }) -> trace (Bad_contract_parameter self_contract) (lift_execution_arg ctxt ~internal entrypoint_ty construct arg) @@ -1990,7 +2162,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal >>=? fun (storage, lazy_storage_diff, ctxt) -> trace Cannot_serialize_storage - ( unparse_data ctxt mode storage_type storage + ( (unparse_data [@coq_type_annotation]) ctxt mode storage_type storage >>=? fun (unparsed_storage, ctxt) -> Lwt.return ( Gas.consume ctxt (Script.strip_locations_cost unparsed_storage) diff --git a/src/proto_014_PtKathma/lib_protocol/script_interpreter_defs.ml b/src/proto_014_PtKathma/lib_protocol/script_interpreter_defs.ml index 2dd948c23ffd0..6e4b61e48b441 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_interpreter_defs.ml @@ -71,290 +71,268 @@ 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 + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | IList_map _, (list : _ boxed_list), _ -> Interp_costs.list_map list + | IList_iter _, (list : _ boxed_list), _ -> Interp_costs.list_iter list + | ISet_iter _, (set : _ set), _ -> Interp_costs.set_iter set + | ISet_mem _, v, (stack : _ * _) -> + let set, _ = stack in Interp_costs.set_mem v set - | ISet_update _ -> - let v = accu and _, (set, _) = stack in + | ISet_update _, v, (stack : _ * (_ * _)) -> + let _, (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 + | IMap_map _, (map : (_, _) map), _ -> Interp_costs.map_map map + | IMap_iter _, (map : (_, _) map), _ -> Interp_costs.map_iter map + | IMap_mem _, v, (stack : (a, _) map * _) -> + let map, _ = stack in Interp_costs.map_mem v map - | IMap_get _ -> - let v = accu and map, _ = stack in + | IMap_get _, v, (stack : (a, _) map * _) -> + let map, _ = stack in Interp_costs.map_get v map - | IMap_update _ -> - let k = accu and _, (map, _) = stack in + | IMap_update _, k, (stack : _ * ((a, _) map * _)) -> + let _, (map, _) = stack in Interp_costs.map_update k map - | IMap_get_and_update _ -> - let k = accu and _, (map, _) = stack in + | IMap_get_and_update _, k, (stack : _ * ((a, _) map * _)) -> + let _, (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 _ -> + | IBig_map_get _, _, (stack : (a, _) big_map * _) -> let Big_map map, _ = stack in Interp_costs.big_map_get map.diff - | IBig_map_update _ -> + | IBig_map_mem _, _, (stack : (a, _) big_map * _) -> + let Big_map map, _ = stack in + Interp_costs.big_map_mem map.diff + | IBig_map_update _, _, (stack : _ * ((a, _) big_map * _)) -> let _, (Big_map map, _) = stack in Interp_costs.big_map_update map.diff - | IBig_map_get_and_update _ -> + | IBig_map_get_and_update _, _, (stack : _ * ((a, _) big_map * _)) -> 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 + | ( IAdd_seconds_to_timestamp _, + (n : _ Script_int.num), + (stack : Script_timestamp.t * _) ) -> + let t, _ = stack in Interp_costs.add_seconds_timestamp n t - | IAdd_timestamp_to_seconds _ -> - let t = accu and n, _ = stack in + | ( IAdd_timestamp_to_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let n, _ = stack in Interp_costs.add_timestamp_seconds t n - | ISub_timestamp_seconds _ -> - let t = accu and n, _ = stack in + | ( ISub_timestamp_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let n, _ = stack in Interp_costs.sub_timestamp_seconds t n - | IDiff_timestamps _ -> - let t1 = accu and t2, _ = stack in + | ( IDiff_timestamps _, + (t1 : Script_timestamp.t), + (stack : Script_timestamp.t * _) ) -> + let t2, _ = stack in Interp_costs.diff_timestamps t1 t2 - | IConcat_string_pair _ -> - let x = accu and y, _ = stack in + | IConcat_string_pair _, (x : Script_string.t), (stack : Script_string.t * _) + -> + let y, _ = stack in Interp_costs.concat_string_pair x y - | IConcat_string _ -> - let ss = accu in + | IConcat_string _, (ss : _ boxed_list), _ -> Interp_costs.concat_string_precheck ss - | ISlice_string _ -> - let _offset = accu in + | ISlice_string _, _offset, (stack : _ Script_int.num * (Script_string.t * _)) + -> let _length, (s, _) = stack in Interp_costs.slice_string s - | IConcat_bytes_pair _ -> - let x = accu and y, _ = stack in + | IConcat_bytes_pair _, (x : bytes), (stack : bytes * _) -> + let y, _ = stack in Interp_costs.concat_bytes_pair x y - | IConcat_bytes _ -> - let ss = accu in + | IConcat_bytes _, (ss : _ boxed_list), _ -> Interp_costs.concat_string_precheck ss - | ISlice_bytes _ -> + | ISlice_bytes _, _, (stack : _ * (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 + | IMul_teznat _, _, _ -> Interp_costs.mul_teznat + | IMul_nattez _, _, _ -> Interp_costs.mul_nattez + | IAbs_int _, (x : _ Script_int.num), _ -> Interp_costs.abs_int x + | INeg _, (x : _ Script_int.num), _ -> Interp_costs.neg x + | IAdd_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.add_int x y - | IAdd_nat _ -> - let x = accu and y, _ = stack in + | IAdd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.add_nat x y - | ISub_int _ -> - let x = accu and y, _ = stack in + | ISub_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.sub_int x y - | IMul_int _ -> - let x = accu and y, _ = stack in + | IMul_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.mul_int x y - | IMul_nat _ -> - let x = accu and y, _ = stack in + | IMul_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.mul_nat x y - | IEdiv_teznat _ -> - let x = accu and y, _ = stack in + | IEdiv_teznat _, x, (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_teznat x y - | IEdiv_int _ -> - let x = accu and y, _ = stack in + | IEdiv_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_int x y - | IEdiv_nat _ -> - let x = accu and y, _ = stack in + | IEdiv_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let 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 + | ILsl_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsl_nat x + | ILsr_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsr_nat x + | IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.or_nat x y - | IAnd_nat _ -> - let x = accu and y, _ = stack in + | IAnd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.and_nat x y - | IAnd_int_nat _ -> - let x = accu and y, _ = stack in + | IAnd_int_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.and_int_nat x y - | IXor_nat _ -> - let x = accu and y, _ = stack in + | IXor_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let 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 + | INot_int _, (x : _ Script_int.num), _ -> Interp_costs.not_int x + | ICompare (_, ty, _), a, (stack : a * _) -> + let b, _ = stack in Interp_costs.compare ty a b - | ICheck_signature _ -> - let key = accu and _, (message, _) = stack in + | ICheck_signature _, (key : public_key), (stack : _ * (bytes * _)) -> + let _, (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 + | IHash_key _, (pk : public_key), _ -> Interp_costs.hash_key pk + | IBlake2b _, (bytes : bytes), _ -> Interp_costs.blake2b bytes + | ISha256 _, (bytes : bytes), _ -> Interp_costs.sha256 bytes + | ISha512 _, (bytes : bytes), _ -> Interp_costs.sha512 bytes + | IKeccak _, (bytes : bytes), _ -> Interp_costs.keccak bytes + | ISha3 _, (bytes : bytes), _ -> Interp_costs.sha3 bytes + | IPairing_check_bls12_381 _, (pairs : _ boxed_list), _ -> Interp_costs.pairing_check_bls12_381 pairs - | ISapling_verify_update _ -> + | ISapling_verify_update _, (accu : Sapling_repr.transaction), _ -> 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 _ -> + | ( ISapling_verify_update_deprecated _, + (accu : Sapling_repr.legacy_transaction), + _ ) -> 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 ticket = accu and (amount_a, amount_b), _ = stack in + | ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _) -> + let ticket = accu in + let (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 + | IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _ -> + let ticket_a, ticket_b = ticket_a_b 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 _ -> 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 _ -> + | 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 _, _, _ -> 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 _, (accu : bytes), _ -> 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 _ -> + | 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 _, _, _ -> . + | 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 _, (accu : _ Script_int.num), _ -> let z = accu in Interp_costs.mul_bls12_381_fr_z z - | IMul_bls12_381_z_fr _ -> + | IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _) -> 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 - | IOpen_chest _ -> - let _chest_key = accu and chest, (time, _) = stack in + | 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 + | ( IOpen_chest _, + _chest_key, + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> + let chest, (time, _) = stack in Interp_costs.open_chest ~chest ~time:(Script_int.to_zint time) - | IEmit _ -> Interp_costs.emit - | ILog _ -> Gas.free + | IEmit _, _, _ -> Interp_costs.emit + | ILog _, _, _ -> Gas.free [@@ocaml.inline always] - [@@coq_axiom_with_reason "unreachable expression `.` not handled"] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = fun ks -> @@ -411,7 +389,7 @@ let get_log = function (* The following function pops n elements from the stack and push their reintroduction in the continuations stack. *) -let rec kundip : +let[@coq_struct "w_value"] 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 -> @@ -419,23 +397,24 @@ let rec kundip : (d, w, b, t) kinstr -> a * s * (e, z, b, t) kinstr = fun w accu stack k -> - match w with - | KPrefix (loc, ty, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | KPrefix (loc, ty, w), _, (stack : _ * _) -> let k = IConst (loc, ty, accu, k) in let accu, stack = stack in kundip w accu stack k - | KRest -> (accu, stack, k) + | KRest, (accu : a), (stack : s) -> (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 + match[@coq_match_with_default] descr.kbef with + | Item_t (full_arg_ty, _) -> ( let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> let loc = Micheline.dummy_location in unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> - match full_arg_ty with + match[@coq_match_with_default] full_arg_ty with | Pair_t (capture_ty, arg_ty, _, _) -> let arg_stack_ty = Item_t (arg_ty, Bot_t) in let full_descr = @@ -463,6 +442,7 @@ let apply ctxt gas capture_ty capture lam = let lam' = Lam (full_descr, full_expr) in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in return (lam', ctxt, gas) + ) let make_transaction_to_contract ctxt ~destination ~amount ~entrypoint ~location ~parameters_ty ~parameters = @@ -695,7 +675,7 @@ let unpack ctxt ~ty ~bytes = 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 : +let[@coq_struct "n_value"] 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 -> @@ -703,11 +683,11 @@ let rec interp_stack_prefix_preserving_operation : u -> (d * w) * result = fun f n accu stk -> - match (n, stk) with - | KPrefix (_, _, n), rest -> + match[@coq_match_gadt_with_result] (n, accu, 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 + | KRest, (accu : a), (v : s) -> f accu v (* diff --git a/src/proto_014_PtKathma/lib_protocol/script_ir_annot.ml b/src/proto_014_PtKathma/lib_protocol/script_ir_annot.ml index a9d0cdfce7ddb..faeb1dfe05227 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_ir_annot.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_ir_annot.ml @@ -42,7 +42,7 @@ let error_unexpected_annot loc annot = (* Check that the predicate p holds on all s.[k] for k >= i *) let string_iter p s i = let len = String.length s in - let rec aux i = + let[@coq_struct "i_value"] rec aux i = if Compare.Int.(i >= len) then Result.return_unit else p s.[i] >>? fun () -> aux (i + 1) in diff --git a/src/proto_014_PtKathma/lib_protocol/script_ir_translator.ml b/src/proto_014_PtKathma/lib_protocol/script_ir_translator.ml index 72bcf44899f10..1ac17dbc988aa 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_ir_translator.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_ir_translator.ml @@ -157,7 +157,7 @@ let unparse_memo_size ~loc memo_size = let z = Sapling.Memo_size.unparse_to_z memo_size in Int (loc, z) -let rec unparse_ty_and_entrypoints_uncarbonated : +let[@coq_struct "ty_value"] rec unparse_ty_and_entrypoints_uncarbonated : type a ac loc. loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = fun ~loc ty {nested = nested_entrypoints; at_node} -> @@ -266,7 +266,7 @@ let rec unparse_ty_and_entrypoints_uncarbonated : in Prim (loc, name, args, annot) -and unparse_comparable_ty_uncarbonated : +and[@coq_struct "ty_value"] unparse_comparable_ty_uncarbonated : type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints @@ -291,7 +291,7 @@ let serialize_ty_for_error ty = *) unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations -let[@coq_axiom_with_reason "gadt"] check_comparable : +let check_comparable : type a ac. Script.location -> (a, ac) ty -> (ac, Dependent_bool.yes) eq tzresult = fun loc ty -> @@ -521,7 +521,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : +let[@coq_struct "ty_value"] rec unparse_comparable_data : type a loc. loc:loc -> context -> @@ -539,33 +539,37 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : [unparse_data] for now. *) >>?= fun ctxt -> - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | Unit_t, (v : unit) -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, (s : Script_string.t) -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, (s : bytes) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, (b : bool) -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, (t : Script_timestamp.t) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, (address : address) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, (address : tx_rollup_l2_address) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Chain_id_t, chain_id -> + | Signature_t, (s : Script_signature.t) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, (v : Tez_repr.t) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, (k : public_key) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, (k : public_key_hash) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Chain_id_t, (chain_id : Script_chain_id.t) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Pair_t (tl, tr, _, YesYes), pair -> + | Pair_t (tl, tr, _, YesYes), (pair : _ * _) -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, YesYes), v -> + | Union_t (tl, tr, _, YesYes), (v : _ union) -> let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, Yes), v -> + | Option_t (t, _, Yes), (v : _ option) -> let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v | Never_t, _ -> . @@ -596,10 +600,11 @@ let hash_comparable_data ctxt ty data = (* ---- Tickets ------------------------------------------------------------ *) (* - All comparable types are dupable, this function exists only to not forget - checking this property when adding new types. -*) -let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function + All comparable types are dupable, this function exists only to not forget + checking this property when adding new types. + *) +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = + function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ -> @@ -645,13 +650,13 @@ let check_dupable_ty ctxt loc ty = aux loc ty_b | Lambda_t (_, _, _) -> (* - Lambda are dupable as long as: - - they don't contain non-dupable values, e.g. in `PUSH` - (mostly non-dupable values should probably be considered forged) - - they are not the result of a partial application on a non-dupable - value. `APPLY` rejects non-packable types (because of `PUSH`). - Hence non-dupable should imply non-packable. - *) + Lambda are dupable as long as: + - they don't contain non-dupable values, e.g. in `PUSH` + (mostly non-dupable values should probably be considered forged) + - they are not the result of a partial application on a non-dupable + value. `APPLY` rejects non-packable types (because of `PUSH`). + Hence non-dupable should imply non-packable. + *) return_unit | Option_t (ty, _, _) -> aux loc ty | List_t (ty, _) -> aux loc ty @@ -693,7 +698,7 @@ let memo_size_eq : if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative _ -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) @@ -722,27 +727,18 @@ let rec ty_eq : (ta, tac) ty -> (tb, tbc) ty -> (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = - fun ty1 ty2 -> - help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun loc -> - default_ty_eq_error loc ty1 ty2) - and help0 : - type ta tac tb tbc. - (ta, tac) ty -> - (tb, tbc) ty -> - (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = fun ty1 ty2 -> let open Gas_monad.Syntax in let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in let not_equal () = Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative loc -> trace_of_error @@ default_ty_eq_error loc ty1 ty2) in - match (ty1, ty2) with + (match (ty1, ty2) with | Unit_t, Unit_t -> return (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) | Unit_t, _ -> not_equal () | Int_t, Int_t -> return Eq @@ -854,10 +850,13 @@ let rec ty_eq : | Chest_t, Chest_t -> return Eq | Chest_t, _ -> not_equal () | Chest_key_t, Chest_key_t -> return Eq - | Chest_key_t, _ -> not_equal () + | Chest_key_t, _ -> not_equal ()) + |> Gas_monad.record_trace_eval ~error_details (fun loc -> + default_ty_eq_error loc ty1 ty2) in help ty1 ty2 - [@@coq_axiom_with_reason "non-top-level mutual recursion"] + |> Gas_monad.record_trace_eval ~error_details (fun loc -> + default_ty_eq_error loc ty1 ty2) (* Same as ty_eq but for stacks. A single error monad is used here because there is no need to @@ -890,6 +889,7 @@ type ('a, 's) judgement = descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr; } -> ('a, 's) judgement +[@@coq_force_gadt] (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) @@ -942,7 +942,7 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -type ex_ty = Ex_ty : ('a, _) ty -> ex_ty +type ex_ty = Ex_ty : ('a, _) ty -> ex_ty [@@coq_force_gadt] type ex_parameter_ty_and_entrypoints_node = | Ex_parameter_ty_and_entrypoints_node : { @@ -952,20 +952,20 @@ type ex_parameter_ty_and_entrypoints_node = -> ex_parameter_ty_and_entrypoints_node (** [parse_ty] can be used to parse regular types as well as parameter types - together with their entrypoints. + together with their entrypoints. - In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will - return an [ex_ty]. + In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will + return an [ex_ty]. - In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return - an [ex_parameter_ty_and_entrypoints_node]. -*) + In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return + an [ex_parameter_ty_and_entrypoints_node]. + *) type ('ret, 'name) parse_ty_ret = | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty : +let[@coq_struct "node_value"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -991,13 +991,13 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty error Typechecking_too_many_recursive_calls else (match ret with - | Don't_parse_entrypoints -> ok (node, (() : name)) + | Don't_parse_entrypoints -> ok (node, None) | Parse_entrypoints -> extract_entrypoint_annot node) >>? fun (node, name) -> let return ctxt ty : ret * context = - match ret with - | Don't_parse_entrypoints -> (Ex_ty ty, ctxt) - | Parse_entrypoints -> + match[@coq_match_gadt_with_result] (ret, name) with + | Don't_parse_entrypoints, _ -> (Ex_ty ty, ctxt) + | Parse_entrypoints, (name : Alpha_context.Entrypoint.t option) -> let at_node = Option.map (fun name -> {name; original_type_expr = node}) name in @@ -1058,7 +1058,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1070,7 +1070,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> remove_field_annot utl >>? fun utl -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1087,7 +1087,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, utr, []))) >>? fun utr -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1107,7 +1107,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty remove_field_annot utr >|? fun utr -> (utl, utr) | Parse_entrypoints -> ok (utl, utr)) >>? fun (utl, utr) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1118,7 +1118,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1130,12 +1130,15 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty utr >>? fun (parsed_r, ctxt) -> check_type_annot loc annot >>? fun () -> - match ret with - | Don't_parse_entrypoints -> + match[@coq_match_gadt_with_result] (ret, parsed_l, parsed_r, name) with + | Don't_parse_entrypoints, _, _, _ -> let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt) - | Parse_entrypoints -> + | ( Parse_entrypoints, + (parsed_l : ex_parameter_ty_and_entrypoints_node), + (parsed_r : ex_parameter_ty_and_entrypoints_node), + (name : Alpha_context.Entrypoint.t option) ) -> let (Ex_parameter_ty_and_entrypoints_node {arg_type = tl; entrypoints = left}) = parsed_l @@ -1154,9 +1157,9 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) ) | Prim (loc, T_lambda, [uta; utr], annot) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> return ctxt ty @@ -1167,7 +1170,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_composed_type_annot loc annot >>? fun () -> ok ut else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1180,7 +1183,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty >>? fun (Ex_ty t, ctxt) -> option_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_list, [ut], annot) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1195,20 +1198,20 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty list_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> return ctxt ty else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1232,11 +1235,11 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty return ctxt (sapling_transaction_deprecated_t ~memo_size) else error (Deprecated_instruction T_sapling_transaction_deprecated) (* - /!\ When adding new lazy storage kinds, be careful to use - [when allow_lazy_storage] /!\ - Lazy storage should not be packable to avoid stealing a lazy storage - from another contract with `PUSH t id` or `UNPACK`. - *) + /!\ When adding new lazy storage kinds, be careful to use + [when allow_lazy_storage] /!\ + Lazy storage should not be packable to avoid stealing a lazy storage + from another contract with `PUSH t id` or `UNPACK`. + *) | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> parse_big_map_ty ctxt @@ -1305,14 +1308,13 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty T_unit; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_comparable_ty - : +and[@coq_struct "stack_depth"] parse_comparable_ty_aux : context -> stack_depth:int -> Script.node -> (ex_comparable_ty * context) tzresult = fun ctxt ~stack_depth node -> - parse_ty + parse_ty_aux ~ret:Don't_parse_entrypoints ctxt ~stack_depth:(stack_depth + 1) @@ -1329,7 +1331,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_compar error (Comparable_type_expected (location node, Micheline.strip_locations node)) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty : +and[@coq_mutual_as_notation] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -1338,41 +1340,40 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:false - ~allow_contract:true - ~allow_ticket:true + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:true + ~allow_ticket:true [@coq_type_annotation]) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty - : +and[@coq_mutual_as_notation] parse_any_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_ty - ctxt ~stack_depth ~legacy big_map_loc args map_annot = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + ~ret:Don't_parse_entrypoints [@coq_type_annotation]) + +and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc + args map_annot = Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1383,21 +1384,21 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty - ctxt ~stack_depth ~legacy value_ty = - (parse_ty [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:legacy - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - value_ty - -let parse_packable_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) +and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth + ~legacy value_ty = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + ~ret:Don't_parse_entrypoints + value_ty [@coq_type_annotation]) + +let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1411,7 +1412,7 @@ let parse_packable_ty ctxt ~stack_depth ~legacy node = node let parse_view_input_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1423,7 +1424,7 @@ let parse_view_input_ty ctxt ~stack_depth ~legacy node = node let parse_view_output_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1435,7 +1436,7 @@ let parse_view_output_ty ctxt ~stack_depth ~legacy node = node let parse_normal_storage_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1550,6 +1551,7 @@ type ('arg, 'storage) code = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script @@ -1563,6 +1565,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view +[@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) map @@ -1607,16 +1610,19 @@ type 'before comb_get_proof_argument = | Comb_get_proof_argument : ('before, 'after) comb_get_gadt_witness * ('after, _) ty -> 'before comb_get_proof_argument +[@@coq_force_gadt] type ('rest, 'before) comb_set_proof_argument = | Comb_set_proof_argument : ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty -> ('rest, 'before) comb_set_proof_argument +[@@coq_force_gadt] type (_, _, _) dup_n_proof_argument = | Dup_n_proof_argument : ('a, 'b, 's, 't) dup_n_gadt_witness * ('t, _) ty -> ('a, 'b, 's) dup_n_proof_argument + [@@coq_force_gadt] let rec make_dug_proof_argument : type a s x xc. @@ -1685,7 +1691,7 @@ let find_entrypoint (type full fullc error_context error_trace) (full : (full, fullc) ty) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let rec find_entrypoint : + let[@coq_struct "ty_value"] rec find_entrypoint : type t tc. (t, tc) ty -> t entrypoints_node -> @@ -1693,26 +1699,35 @@ let find_entrypoint (type full fullc error_context error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in - match (ty, entrypoints) with + match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) - | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function - | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> - return - (Ex_ty_cstr - { - ty; - construct = (fun e -> L (construct e)); - original_type_expr; - }) - | Error () -> - let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - find_entrypoint tr right entrypoint - in - Ex_ty_cstr - {ty; construct = (fun e -> R (construct e)); original_type_expr}) + | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> + Gas_monad.bind_recover + (find_entrypoint tl left entrypoint) + (function [@coq_match_gadt] + | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> + return + (Ex_ty_cstr + { + ty; + construct = (fun e -> L (construct e)); + original_type_expr; + }) + | Error () -> ( + let+ x = + (find_entrypoint tr right entrypoint [@coq_type_annotation]) + in + match[@coq_match_gadt] x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr + { + ty; + construct = (fun e -> R (construct e)); + original_type_expr; + })) + [@coq_cast] | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -1725,7 +1740,7 @@ let find_entrypoint (type full fullc error_context error_trace) else Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative _ -> trace_of_error @@ No_such_entrypoint entrypoint) @@ -1734,7 +1749,13 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) entrypoints entrypoint : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let* res = find_entrypoint ~error_details full entrypoints entrypoint in + let* res = + (find_entrypoint + ~error_details + full + entrypoints + entrypoint [@coq_type_annotation]) + in match res with | Ex_ty_cstr {ty; _} -> ( match entrypoints.root.at_node with @@ -1812,14 +1833,14 @@ type ex_parameter_ty_and_entrypoints = } -> ex_parameter_ty_and_entrypoints -let parse_parameter_ty_and_entrypoints : +let parse_parameter_ty_and_entrypoints_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_parameter_ty_and_entrypoints * context) tzresult = fun ctxt ~stack_depth ~legacy node -> - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1833,7 +1854,8 @@ let parse_parameter_ty_and_entrypoints : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints +let parse_passable_ty_aux = + parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2178,7 +2200,7 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = (* The limitation of length of string is same as entrypoint *) if Compare.Int.(String.length v > 31) then error (View_name_too_long v) else - let rec check_char i = + let[@coq_struct "i_value"] rec check_char i = if Compare.Int.(i < 0) then ok v else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) else error (Bad_view_name loc) @@ -2194,7 +2216,7 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) -let parse_toplevel : +let parse_toplevel_aux : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = fun ctxt ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ -2289,19 +2311,19 @@ let parse_toplevel : (* -- parse data of any type -- *) (* - Some values, such as operations, tickets, or big map ids, are used only - internally and are not allowed to be forged by users. - In [parse_data], [allow_forged] should be [false] for: - - PUSH - - UNPACK - - user-provided script parameters - - storage on origination - And [true] for: - - internal calls parameters - - storage after origination -*) + Some values, such as operations, tickets, or big map ids, are used only + internally and are not allowed to be forged by users. + In [parse_data], [allow_forged] should be [false] for: + - PUSH + - UNPACK + - user-provided script parameters + - storage on origination + And [true] for: + - internal calls parameters + - storage after origination + *) -let[@coq_axiom_with_reason "gadt"] rec parse_data : +let[@coq_struct "ctxt"] rec parse_data_aux : type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2317,7 +2339,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : if Compare.Int.(stack_depth > 10_000) then fail Typechecking_too_many_recursive_calls else - parse_data + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -2445,7 +2467,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : |> traced >|=? fun (_, map, ctxt) -> (map, ctxt) in - match (ty, script_data) with + match[@coq_match_gadt_with_result] (ty, script_data) with | Unit_t, expr -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -2473,7 +2495,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in - parse_contract_data + parse_contract_data_aux ~stack_depth:(stack_depth + 1) ctxt loc @@ -2513,7 +2535,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : tr script_instr | Lambda_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | Option_t (t, _, _), expr -> let parse_v ctxt v = @@ -2530,7 +2553,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : items (Script_list.empty, ctxt) | List_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | Ticket_t (t, _ty_name), expr -> if allow_forged then @@ -2538,7 +2562,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : non_terminal_recursion ?type_logger ctxt ~legacy ty expr >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) -> match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Contract ticketer -> return ({ticketer; contents = contents [@coq_type_annotation]; amount}, ctxt) | Tx_rollup _ | Sc_rollup _ -> fail (Unexpected_ticket_owner destination) else traced_fail (Unexpected_forged_value (location expr)) @@ -2575,16 +2599,28 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : vs >|=? fun (_, set, ctxt) -> (set, ctxt) | Set_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) + ((parse_items [@coq_type_annotation]) + ?type_logger + ctxt + expr + tk + tv + vs + (fun x -> x) + : (_ map * _) tzresult Lwt.t) | Map_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) | Big_map_t (tk, tv, _ty_name), expr -> (match expr with | Int (loc, id) -> - return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + return + (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + [@coq_type_annotation] | Seq (_, vs) -> parse_big_map_items ?type_logger ctxt expr tk tv vs (fun x -> Some x) >|=? fun (diff, ctxt) -> (None, diff, ctxt) @@ -2612,12 +2648,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | _, None -> traced_fail (Invalid_big_map (loc, id)) | ctxt, Some (btk, btv) -> Lwt.return - ( parse_comparable_ty + ( parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2642,14 +2678,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g1_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_g2_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g2_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_fr_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with @@ -2659,11 +2697,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) | Bls12_381_fr_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* - /!\ When adding new lazy storage kinds, you may want to guard the parsing - of identifiers with [allow_forged]. - *) + /!\ When adding new lazy storage kinds, you may want to guard the parsing + of identifiers with [allow_forged]. + *) (* Sapling *) | Sapling_transaction_t memo_size, Bytes (_, bytes) -> ( match @@ -2681,7 +2720,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> ( match Data_encoding.Binary.of_bytes_opt @@ -2700,7 +2740,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_deprecated_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2714,11 +2755,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) | Sapling_state_t memo_size, Seq (_, []) -> - return (Sapling.empty_state ~memo_size (), ctxt) + ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt) + : (Sapling.state * _) tzresult Lwt.t) | Sapling_state_t _, expr -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) - traced_fail + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | Chest_key_t, Bytes (_, bytes) -> ( @@ -2731,7 +2773,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) | Chest_key_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Chest_t, Bytes (_, bytes) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> @@ -2741,9 +2784,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) | Chest_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and parse_view : +and[@coq_struct "ctxt"] parse_view : type storage storagec. ?type_logger:type_logger -> context -> @@ -2767,7 +2811,7 @@ and parse_view : (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) >>?= fun (Ex_ty output_ty, ctxt) -> pair_t input_ty_loc input_ty storage_type >>?= fun (Ty_ex_c pair_ty) -> - parse_instr + parse_instr_aux ?type_logger ~stack_depth:0 Tc_context.view @@ -2807,7 +2851,7 @@ and parse_view : ctxt ) | _ -> error (ill_type_view aft loc)) -and parse_views : +and[@coq_mutual_as_notation] parse_views : type storage storagec. ?type_logger:type_logger -> context -> @@ -2824,7 +2868,7 @@ and parse_views : in Script_map.map_es_in_context aux ctxt views -and[@coq_axiom_with_reason "gadt"] parse_returning : +and[@coq_mutual_as_notation] parse_returning : type arg argc ret retc. ?type_logger:type_logger -> stack_depth:int -> @@ -2836,7 +2880,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ?type_logger ~stack_depth tc_context ctxt ~legacy arg ret script_instr -> - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -2867,7 +2911,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_axiom_with_reason "gadt"] parse_instr : +and[@coq_struct "ctxt"] parse_instr_aux : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -2913,7 +2957,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : if Compare.Int.(stack_depth > 10000) then fail Typechecking_too_many_recursive_calls else - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -3045,9 +3089,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc swap stack_ty | Prim (loc, I_PUSH, [t; d], annot), stack -> check_var_annot loc annot >>?= fun () -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t - >>?= fun (Ex_ty t, ctxt) -> - parse_data + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -3056,7 +3100,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : t d >>=? fun (v, ctxt) -> - let const = {apply = (fun k -> IConst (loc, t, v, k))} in + let const = {apply = (fun k -> IConst (loc, t, (v [@coq_type_annotation]), k))} in typed ctxt loc const (Item_t (t, stack)) | Prim (loc, I_UNIT, [], annot), stack -> check_var_type_annot loc annot >>?= fun () -> @@ -3068,7 +3112,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let cons_some = {apply = (fun k -> ICons_some (loc, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | Prim (loc, I_NONE, [t], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun k -> ICons_none (loc, t, k))} in @@ -3147,8 +3191,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | 1, Item_t _ -> ok (Comb_proof_argument (Comb_one, stack_ty)) | n, Item_t (a_ty, (Item_t _ as tl_ty)) -> make_proof_argument (n - 1) tl_ty - >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) - -> + >>? fun [@coq_match_with_default] (Comb_proof_argument + ( comb_witness, + Item_t (b_ty, tl_ty') )) -> pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) -> Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) | _ -> bad_stack_error ctxt loc I_PAIR 1 @@ -3163,7 +3208,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc comb after_ty | Prim (loc, I_UNPAIR, [n], annot), (Item_t _ as stack_ty) -> error_unexpected_annot loc annot >>?= fun () -> - let rec make_proof_argument : + let[@coq_struct "n_value"] rec make_proof_argument : type a b s. int -> (a, b * s) stack_ty -> (a, b, s) uncomb_proof_argument tzresult = @@ -3222,7 +3267,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc cdr (Item_t (b, rest)) (* unions *) | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_left = {apply = (fun k -> ICons_left (loc, tr, k))} in @@ -3230,7 +3275,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_right = {apply = (fun k -> ICons_right (loc, tl, k))} in @@ -3274,7 +3319,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) | Prim (loc, I_NIL, [t], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun k -> INil (loc, t, k))} in @@ -3392,7 +3437,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) (* sets *) | Prim (loc, I_EMPTY_SET, [t], annot), rest -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun k -> IEmpty_set (loc, t, k))} in @@ -3451,9 +3496,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun k -> IEmpty_map (loc, tk, tv, k))} in @@ -3575,9 +3620,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun k -> IEmpty_big_map (loc, tk, tv, k))} in @@ -3801,9 +3846,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -4236,7 +4281,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> check_var_annot loc annot >>?= fun () -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t >>?= fun (eq, ctxt) -> @@ -4261,7 +4306,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> @@ -4275,7 +4320,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (address_t, rest) in typed ctxt loc instr stack | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) -> - parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> option_t loc contract_ty >>?= fun res_ty -> @@ -4333,11 +4378,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - parse_toplevel ctxt ~legacy canonical_code + parse_toplevel_aux ctxt ~legacy canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) - (parse_parameter_ty_and_entrypoints + (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -4366,10 +4411,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : arg_type_full ret_type_full code_field) - >>=? fun ( Lam - ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, - _ ), - ctxt ) -> + >>=? fun [@coq_match_with_default] ( Lam + ( { + kbef = Item_t (arg, Bot_t); + kaft = Item_t (ret, Bot_t); + _; + }, + _ ), + ctxt ) -> let views_result = parse_views ctxt ?type_logger ~legacy storage_type views in @@ -4450,7 +4499,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint -> let open Tc_context in - match tc_context.callsite with + match[@coq_match_gadt] tc_context.callsite with | _ when is_in_lambda tc_context -> error (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim)) @@ -4463,11 +4512,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt - @@ find_entrypoint - ~error_details:(Informative ()) - param_type - entrypoints - entrypoint + @@ (find_entrypoint + ~error_details:(Informative ()) + param_type + entrypoints + entrypoint [@coq_type_annotation]) >>? fun (r, ctxt) -> r >>? fun (Ex_ty_cstr {ty = param_type; _}) -> contract_t loc param_type >>? fun res_ty -> @@ -4653,7 +4702,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in typed ctxt loc instr (Item_t (Operation_t, rest)) | Prim (loc, I_EMIT, [ty_node], annot), Item_t (data, rest) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty_node + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty_node >>?= fun (Ex_ty ty, ctxt) -> check_item_ty ctxt ty data loc I_EMIT 1 2 >>?= fun (Eq, ctxt) -> parse_entrypoint_annot_strict loc annot >>?= fun tag -> @@ -4864,27 +4913,6 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : I_XOR; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_data : - type arg argc. - stack_depth:int -> - context -> - Script.location -> - (arg, argc) ty -> - Destination.t -> - entrypoint:Entrypoint.t -> - (context * arg typed_contract) tzresult Lwt.t = - fun ~stack_depth ctxt loc arg destination ~entrypoint -> - let error_details = Informative loc in - parse_contract - ~stack_depth:(stack_depth + 1) - ctxt - ~error_details - loc - arg - destination - ~entrypoint - >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res)) - (* [parse_contract] is used both to: - parse contract data by [parse_data] ([parse_contract_data]) - to execute the [CONTRACT] instruction ([parse_contract_for_script]). @@ -4896,7 +4924,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra The inner [result] is turned into an [option] by [parse_contract_for_script]. Both [tzresult] are merged by [parse_contract_data]. *) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract : +and[@coq_mutual_as_notation] parse_contract : type arg argc err. stack_depth:int -> context -> @@ -4910,7 +4938,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let error ctxt f_err : context * (_, err) result = ( ctxt, Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : err) | Informative loc -> trace_of_error @@ f_err loc) ) in @@ -4947,18 +4975,20 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra code >>? fun (code, ctxt) -> (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code + parse_toplevel_aux ctxt ~legacy:true code >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true arg_type - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) -> Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) ~error_details ~full:targ ~expected:arg @@ -4997,16 +5027,17 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra ctxt parameters_type >>? fun (parameters_type, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true (root parameters_type) - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = full; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = full; entrypoints}, + ctxt ) -> Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit "full" "__Ex_parameter_ty_and_entrypoints_'a2"]) ~error_details ~full ~expected:arg @@ -5018,6 +5049,27 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let address = {destination; entrypoint} in Typed_contract {arg_ty; address} )) +and[@coq_mutual_as_notation] parse_contract_data_aux : + type arg argc. + stack_depth:int -> + context -> + Script.location -> + (arg, argc) ty -> + Destination.t -> + entrypoint:Entrypoint.t -> + (context * arg typed_contract) tzresult Lwt.t = + fun ~stack_depth ctxt loc arg destination ~entrypoint -> + let error_details = Informative loc in + parse_contract + ~stack_depth:(stack_depth + 1) + ctxt + ~error_details + loc + arg + destination + ~entrypoint + >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res)) + (* Same as [parse_contract], but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. @@ -5075,12 +5127,16 @@ let parse_code : code >>?= fun (code, ctxt) -> Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code + parse_toplevel_aux ctxt ~legacy code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5128,7 +5184,7 @@ let parse_storage : (fun () -> let storage_type = serialize_ty_for_error storage_type in Ill_typed_data (None, storage, storage_type)) - (parse_data + (parse_data_aux ?type_logger ~stack_depth:0 ctxt @@ -5137,7 +5193,7 @@ let parse_storage : storage_type (root storage)) -let[@coq_axiom_with_reason "gadt"] parse_script : +let parse_script : ?type_logger:type_logger -> context -> legacy:bool -> @@ -5146,10 +5202,17 @@ let[@coq_axiom_with_reason "gadt"] parse_script : (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} -> parse_code ~legacy ctxt ?type_logger ~code - >>=? fun ( Ex_code - (Code - {code; arg_type; storage_type; views; entrypoints; code_size}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_code + (Code + { + code; + arg_type; + storage_type; + views; + entrypoints; + code_size; + }), + ctxt ) -> parse_storage ?type_logger ctxt @@ -5160,7 +5223,15 @@ let[@coq_axiom_with_reason "gadt"] parse_script : >|=? fun (storage, ctxt) -> ( Ex_script (Script - {code_size; code; arg_type; storage; storage_type; views; entrypoints}), + { + code_size; + code; + arg_type; + storage = storage [@coq_type_annotation]; + storage_type; + views; + entrypoints; + }), ctxt ) type typechecked_code_internal = @@ -5174,7 +5245,7 @@ type typechecked_code_internal = } -> typechecked_code_internal -let typecheck_code : +let typecheck_code_aux : legacy:bool -> show_types:bool -> context -> @@ -5183,13 +5254,17 @@ let typecheck_code : fun ~legacy ~show_types ctxt code -> (* Constants need to be expanded or [parse_toplevel] may fail. *) Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) -> + parse_toplevel_aux ctxt ~legacy code >>?= fun (toplevel, ctxt) -> let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5277,13 +5352,12 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true) in fold_tree full entrypoints.root [] reachable ([], init) - [@@coq_axiom_with_reason "unsupported syntax"] (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) (* -- Unparsing data of any type -- *) -let[@coq_axiom_with_reason "gadt"] rec unparse_data : +let[@coq_struct "ctxt"] rec unparse_data_aux : type a ac. context -> stack_depth:int -> @@ -5296,46 +5370,53 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let non_terminal_recursion ctxt mode ty a = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | Unit_t, (v : unit) -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, (s : Script_string.t) -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, (s : bytes) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, (b : bool) -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, (t : Script_timestamp.t) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, (address : address) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, (address : tx_rollup_l2_address) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Contract_t _, contract -> + | Contract_t _, (contract : _ typed_contract) -> Lwt.return @@ unparse_contract ~loc ctxt mode contract - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Operation_t, operation -> + | Signature_t, (s : signature) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, (v : Tez_repr.t) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, (k : public_key) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, (k : public_key_hash) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Operation_t, (operation : operation) -> Lwt.return @@ unparse_operation ~loc ctxt operation - | Chain_id_t, chain_id -> + | Chain_id_t, (chain_id : Script_chain_id.t) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | Pair_t (tl, tr, _, _), pair -> + | Bls12_381_g1_t, (x : Script_bls.G1.t) -> + Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | Bls12_381_g2_t, (x : Script_bls.G2.t) -> + Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | Bls12_381_fr_t, (x : Script_bls.Fr.t) -> + Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x + | Pair_t (tl, tr, _, _), (pair : _ * _) -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, _), v -> + | Union_t (tl, tr, _, _), (v : _ union) -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, _), v -> + | Option_t (t, _, _), (v : _ option) -> let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in unparse_option ~loc unparse_v ctxt v - | List_t (t, _), items -> + | List_t (t, _), (items : _ boxed_list) -> List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -5343,18 +5424,19 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) items.elements >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | Ticket_t (t, _), {ticketer; contents; amount} -> + | Ticket_t (t, _), (x : _ ticket) -> + let {ticketer; contents; amount} = x in (* ideally we would like to allow a little overhead here because it is only used for unparsing *) opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data [@tailcall]) + (unparse_data_aux [@tailcall]) ctxt ~stack_depth mode t (addr, (contents, amount)) - | Set_t (t, _), set -> + | Set_t (t, _), (set : _ set) -> List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> @@ -5362,65 +5444,68 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Map_t (kt, vt, _), map -> + | Map_t (kt, vt, _), (map : _ map) -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} - when Compare.Int.( = ) size 0 -> - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + | Big_map_t (kt, vt, _), (x : _ big_map) -> ( + match[@coq_match_gadt] x with + | Big_map {id = Some id; diff = {size; _}; _} + when Compare.Int.( = ) size 0 -> + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + | Big_map {id = Some id; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] + in + let items = + (* Sort the items in Michelson comparison order and not in key + hash order. This code path is only exercised for tracing, + so we don't bother carbonating this sort operation + precisely. Also, the sort uses a reverse compare because + [unparse_items] will reverse the result. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + (* this can't fail if the original type is well-formed + because [option vt] is always strictly smaller than [big_map kt vt] *) + option_t loc vt >>?= fun vt -> + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ), + ctxt ) + | Big_map {id = None; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + map + [] + in + let items = + (* See note above. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)) + | Lambda_t _, (x : _ lambda) -> + let (Lam (_, original_code)) = x in + unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code | Never_t, _ -> . - | Sapling_transaction_t _, s -> + | Sapling_transaction_t _, (s : Sapling.transaction) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in (Bytes (loc, bytes), ctxt) ) - | Sapling_transaction_deprecated_t _, s -> + | Sapling_transaction_deprecated_t _, (s : Sapling_repr.legacy_transaction) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) >|? fun ctxt -> @@ -5430,7 +5515,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : s in (Bytes (loc, bytes), ctxt) ) - | Sapling_state_t _, {id; diff; _} -> + | Sapling_state_t _, (x : Sapling.state) -> + let {Sapling.id; diff; _} = x in Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with @@ -5452,14 +5538,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : Micheline.Prim (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) - | Chest_key_t, s -> + | Chest_key_t, (s : Script_timelock.chest_key) -> unparse_with_data_encoding ~loc ctxt s Unparse_costs.chest_key Script_timelock.chest_key_encoding - | Chest_t, s -> + | Chest_t, (s : Script_timelock.chest) -> unparse_with_data_encoding ~loc ctxt @@ -5468,7 +5554,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ~plaintext_size:(Script_timelock.get_plaintext_size s)) Script_timelock.chest_encoding -and unparse_items : +and[@coq_mutual_as_notation] unparse_items : type k v vc. context -> stack_depth:int -> @@ -5482,23 +5568,23 @@ and unparse_items : (fun (l, ctxt) (k, v) -> let loc = Micheline.dummy_location in unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) items -and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = +and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + else unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun (Ex_ty t, ctxt) -> + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -5506,7 +5592,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - parse_data + parse_data_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -5514,7 +5600,12 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = t data >>=? fun (data, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_aux + ctxt + ~stack_depth:(stack_depth + 1) + mode + t + (data [@coq_type_annotation]) >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -5544,7 +5635,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt code >>?= fun (code, ctxt) -> - typecheck_code ~legacy ~show_types:false ctxt code + typecheck_code_aux ~legacy ~show_types:false ctxt code >>=? fun ( Typechecked_code_internal { toplevel = @@ -5561,15 +5652,15 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage type_map = _; }, ctxt ) -> - parse_storage + (parse_storage [@coq_implicit "storage" "a"]) ctxt ~legacy ~allow_forged:allow_forged_in_storage storage_type ~storage >>=? fun (storage, ctxt) -> - unparse_code ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> - unparse_data ctxt ~stack_depth:0 mode storage_type storage + unparse_code_aux ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> + unparse_data_aux ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> let loc = Micheline.dummy_location in (if normalize_types then @@ -5591,7 +5682,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage >>=? fun (arg_type, storage_type, views, ctxt) -> Script_map.map_es_in_context (fun ctxt _name {input_ty; output_ty; view_code} -> - unparse_code ctxt ~stack_depth:0 mode view_code + unparse_code_aux ctxt ~stack_depth:0 mode view_code >|=? fun (view_code, ctxt) -> ({input_ty; output_ty; view_code}, ctxt)) ctxt views @@ -5629,7 +5720,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt ) let pack_data_with_mode ctxt ty data ~mode = - unparse_data ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> + unparse_data_aux ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt let hash_data ctxt ty data = @@ -5646,60 +5737,63 @@ type lazy_storage_ids = Lazy_storage.IdSet.t let no_lazy_storage_id = Lazy_storage.IdSet.empty let diff_of_big_map ctxt mode ~temporary ~ids_to_copy - (Big_map {id; key_type; value_type; diff}) = - (match id with - | Some id -> - if Lazy_storage.IdSet.mem Big_map id ids_to_copy then - Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> - (ctxt, Lazy_storage.Copy {src = id}, duplicate) - else - (* The first occurrence encountered of a big_map reuses the - ID. This way, the payer is only charged for the diff. - For this to work, this diff has to be put at the end of - the global diff, otherwise the duplicates will use the - updated version as a base. This is true because we add - this diff first in the accumulator of - `extract_lazy_storage_updates`, and this accumulator is not - reversed. *) - return (ctxt, Lazy_storage.Existing, id) - | None -> - Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> - Lwt.return - (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in - Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> - unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> - let key_type = Micheline.strip_locations kt in - let value_type = Micheline.strip_locations kv in - (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) - >>=? fun (ctxt, init, id) -> - let pairs = - Big_map_overlay.fold - (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) - diff.map - [] - in - List.fold_left_es - (fun (acc, ctxt) (key_hash, key, value) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - unparse_comparable_data ~loc:() ctxt mode key_type key - >>=? fun (key_node, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt -> - let key = Micheline.strip_locations key_node in - (match value with - | None -> return (None, ctxt) - | Some x -> - unparse_data ~stack_depth:0 ctxt mode value_type x - >>=? fun (node, ctxt) -> + (big_map : ('a, 'b) big_map) = + match[@coq_match_gadt] big_map with + | Big_map {id; key_type; value_type; diff} -> + (match id with + | Some id -> + if Lazy_storage.IdSet.mem Big_map id ids_to_copy then + Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else + (* The first occurrence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_lazy_storage_updates`, and this accumulator is not + reversed. *) + return (ctxt, Lazy_storage.Existing, id) + | None -> + Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> Lwt.return - ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> - (Some (Micheline.strip_locations node), ctxt) )) - >|=? fun (value, ctxt) -> - let diff_item = Big_map.{key; key_hash; value} in - (diff_item :: acc, ctxt)) - ([], ctxt) - (List.rev pairs) - >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) + (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in + Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> + unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> + let key_type = Micheline.strip_locations kt in + let value_type = Micheline.strip_locations kv in + (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) + >>=? fun (ctxt, init, id) -> + let pairs = + Big_map_overlay.fold + (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) + diff.map + [] + in + List.fold_left_es + (fun (acc, ctxt) (key_hash, key, value) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> + unparse_comparable_data ~loc:() ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost key_node) + >>?= fun ctxt -> + let key = Micheline.strip_locations key_node in + (match value with + | None -> return (None, ctxt) + | Some x -> + unparse_data_aux ~stack_depth:0 ctxt mode value_type x + >>=? fun (node, ctxt) -> + Lwt.return + ( Gas.consume ctxt (Script.strip_locations_cost node) + >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) )) + >|=? fun (value, ctxt) -> + let diff_item = Big_map.{key; key_hash; value} in + (diff_item :: acc, ctxt)) + ([], ctxt) + (List.rev pairs) + >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) let diff_of_sapling_state ctxt ~temporary ~ids_to_copy ({id; diff; memo_size} : Sapling.state) = @@ -5716,21 +5810,21 @@ let diff_of_sapling_state ctxt ~temporary ~ids_to_copy (Lazy_storage.Update {init; updates = diff}, id, ctxt) (** - Witness flag for whether a type can be populated by a value containing a - lazy storage. - [False_f] must be used only when a value of the type cannot contain a lazy - storage. + Witness flag for whether a type can be populated by a value containing a + lazy storage. + [False_f] must be used only when a value of the type cannot contain a lazy + storage. - This flag is built in [has_lazy_storage] and used only in - [extract_lazy_storage_updates] and [collect_lazy_storage]. + This flag is built in [has_lazy_storage] and used only in + [extract_lazy_storage_updates] and [collect_lazy_storage]. - This flag is necessary to avoid these two functions to have a quadratic - complexity in the size of the type. + This flag is necessary to avoid these two functions to have a quadratic + complexity in the size of the type. - Add new lazy storage kinds here. + Add new lazy storage kinds here. - Please keep the usage of this GADT local. -*) + Please keep the usage of this GADT local. + *) type 'ty has_lazy_storage = | Big_map_f : ('a, 'b) big_map has_lazy_storage @@ -5747,11 +5841,11 @@ type 'ty has_lazy_storage = | Map_f : 'v has_lazy_storage -> (_, 'v) map has_lazy_storage (** - This function is called only on storage and parameter types of contracts, - once per typechecked contract. It has a complexity linear in the size of - the types, which happen to be literally written types, so the gas for them - has already been paid. -*) + This function is called only on storage and parameter types of contracts, + once per typechecked contract. It has a complexity linear in the size of + the types, which happen to be literally written types, so the gas for them + has already been paid. + *) let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = fun ty -> let aux1 cons t = @@ -5799,16 +5893,15 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = | Map_t (_, t, _) -> aux1 (fun h -> Map_f h) t (** - Transforms a value potentially containing lazy storage in an intermediary - state to a value containing lazy storage only represented by identifiers. + Transforms a value potentially containing lazy storage in an intermediary + state to a value containing lazy storage only represented by identifiers. - Returns the updated value, the updated set of ids to copy, and the lazy - storage diff to show on the receipt and apply on the storage. + Returns the updated value, the updated set of ids to copy, and the lazy + storage diff to show on the receipt and apply on the storage. -*) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode - ~temporary ids_to_copy acc ty x = - let rec aux : + *) +let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = + let[@coq_struct "has_lazy_storage_value"] rec aux : type a ac. context -> unparsing_mode -> @@ -5821,9 +5914,11 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match (has_lazy_storage, ty, x) with - | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) - | Big_map_f, Big_map_t (_, _, _), map -> + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with + | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] + | Big_map_f, Big_map_t (_, _, _), (map : _ big_map) -> diff_of_big_map ctxt mode ~temporary ~ids_to_copy map >|=? fun (diff, id, ctxt) -> let map = @@ -5838,7 +5933,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Big_map id diff in let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in (ctxt, map, ids_to_copy, diff :: acc) - | Sapling_state_f, Sapling_state_t _, sapling_state -> + | Sapling_state_f, Sapling_state_t _, (sapling_state : Sapling.state) -> diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state >|=? fun (diff, id, ctxt) -> let sapling_state = @@ -5847,22 +5942,48 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Sapling_state id diff in let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in (ctxt, sapling_state, ids_to_copy, diff :: acc) - | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _) -> + let xl, xr = x in aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl >>=? fun (ctxt, xl, ids_to_copy, acc) -> aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr >|=? fun (ctxt, xr, ids_to_copy, acc) -> (ctxt, (xl, xr), ids_to_copy, acc) - | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) - | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) - | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) - | List_f has_lazy_storage, List_t (ty, _), l -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyl + x + ~has_lazy_storage:has_lazy_storage_l + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) + | R x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyr + x + ~has_lazy_storage:has_lazy_storage_r + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) + ) + | Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option) -> ( + match x with + | Some x -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, Some x, ids_to_copy, acc) + | None -> return (ctxt, None, ids_to_copy, acc)) + | List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list) -> List.fold_left_es (fun (ctxt, l, ids_to_copy, acc) x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -5873,7 +5994,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode >|=? fun (ctxt, l, ids_to_copy, acc) -> let reversed = {length = l.length; elements = List.rev l.elements} in (ctxt, reversed, ids_to_copy, acc) - | Map_f has_lazy_storage, Map_t (_, ty, _), map -> + | Map_f has_lazy_storage, Map_t (_, ty, _), (map : _ map) -> let (module M) = Script_map.get_module map in let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in List.fold_left_es @@ -5884,7 +6005,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode (ctxt, M.OPS.empty, ids_to_copy, acc) (bindings M.boxed) >|=? fun (ctxt, m, ids_to_copy, acc) -> - let module M = struct + let module M : + Boxed_map with type key = M.key and type value = M.value = struct module OPS = M.OPS type key = M.key @@ -5894,6 +6016,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let boxed = m let size = M.size + + let boxed_map_tag = () end in ( ctxt, Script_map.make @@ -5902,13 +6026,12 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode and type value = M.value), ids_to_copy, acc ) - | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) in let has_lazy_storage = has_lazy_storage ty in aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage (** We namespace an error type for [fold_lazy_storage]. The error case is only - available when the ['error] parameter is equal to unit. *) + available when the ['error] parameter is equal to unit. *) module Fold_lazy_storage = struct type ('acc, 'error) result = | Ok : 'acc -> ('acc, 'error) result @@ -5916,9 +6039,9 @@ module Fold_lazy_storage = struct end (** Prematurely abort if [f] generates an error. Use this function without the - [unit] type for [error] if you are in a case where errors are impossible. -*) -let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : + [unit] type for [error] if you are in a case where errors are impossible. + *) +let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : type a ac error. f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f -> init:'acc -> @@ -5929,33 +6052,55 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - match (has_lazy_storage, ty, x) with - | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) - | Sapling_state_f, Sapling_state_t _, {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + match[@coq_match_gadt] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with + | Big_map_f, Big_map_t (_, _, _), (x : _ big_map) -> ( + match x with + | Big_map {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) + | Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) + | Sapling_state_f, Sapling_state_t _, (x : Alpha_context.Sapling.state) -> ( + match x with + | {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + | {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) | False_f, _, _ -> ok (Fold_lazy_storage.Ok init, ctxt) - | Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _} -> - ok (Fold_lazy_storage.Ok init, ctxt) - | Sapling_state_f, Sapling_state_t _, {id = None; _} -> - ok (Fold_lazy_storage.Ok init, ctxt) - | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> ( + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ pair) -> ( + let xl, xr = x in fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl >>? fun (init, ctxt) -> match init with | Fold_lazy_storage.Ok init -> fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr | Fold_lazy_storage.Error -> ok (init, ctxt)) - | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | _, Option_t (_, _, _), None -> ok (Fold_lazy_storage.Ok init, ctxt) - | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | List_f has_lazy_storage, List_t (ty, _), l -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + fold_lazy_storage + ~f + ~init + ctxt + tyl + x + ~has_lazy_storage:has_lazy_storage_l + | R x -> + fold_lazy_storage + ~f + ~init + ctxt + tyr + x + ~has_lazy_storage:has_lazy_storage_r) + | Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option) -> ( + match x with + | Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage + | None -> ok (Fold_lazy_storage.Ok init, ctxt)) + | List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list) -> List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -5964,7 +6109,7 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : | Fold_lazy_storage.Error -> ok (init, ctxt)) (Fold_lazy_storage.Ok init, ctxt) l.elements - | Map_f has_lazy_storage, Map_t (_, ty, _), m -> + | Map_f has_lazy_storage, Map_t (_, ty, _), (m : _ map) -> Script_map.fold (fun _ v @@ -5977,23 +6122,26 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : m (ok (Fold_lazy_storage.Ok init, ctxt)) -let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x = +let collect_lazy_storage ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f kind id (acc : (_, never) Fold_lazy_storage.result) = - let acc = match acc with Fold_lazy_storage.Ok acc -> acc in + let acc = + match[@coq_match_with_default] acc with Fold_lazy_storage.Ok acc -> acc + in Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc) in fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage >>? fun (ids, ctxt) -> - match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt) + match[@coq_match_with_default] ids with + | Fold_lazy_storage.Ok ids -> ok (ids, ctxt) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode - ~temporary ~to_duplicate ~to_update ty v = +let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v + = (* - Basically [to_duplicate] are ids from the argument and [to_update] are ids - from the storage before execution (i.e. it is safe to reuse them since they - will be owned by the same contract). - *) + Basically [to_duplicate] are ids from the argument and [to_update] are ids + from the storage before execution (i.e. it is safe to reuse them since they + will be owned by the same contract). + *) let to_duplicate = Lazy_storage.IdSet.diff to_duplicate to_update in extract_lazy_storage_updates ctxt mode ~temporary to_duplicate [] ty v >|=? fun (ctxt, v, alive, diffs) -> @@ -6001,10 +6149,15 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode if temporary then diffs else let dead = Lazy_storage.IdSet.diff to_update alive in - Lazy_storage.IdSet.fold_all - {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)} - dead - diffs + let f kind id acc = + (Lazy_storage.make + [@coq_implicit "a" "unit"] [@coq_implicit "u" "unit"]) + kind + id + Remove + :: acc + in + Lazy_storage.IdSet.fold_all {f} dead diffs in match diffs with | [] -> (v, None, ctxt) @@ -6013,7 +6166,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] -let parse_data = parse_data ~stack_depth:0 +let parse_data = parse_data_aux ~stack_depth:0 let parse_comparable_data = parse_data ~legacy:false ~allow_forged:false @@ -6027,7 +6180,7 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> - parse_instr + parse_instr_aux ~stack_depth:0 ?type_logger tc_context @@ -6036,41 +6189,41 @@ let parse_instr : script_instr stack_ty -let unparse_data = unparse_data ~stack_depth:0 +let unparse_data = unparse_data_aux ~stack_depth:0 let unparse_code ctxt mode code = (* Constants need to be expanded or [unparse_code] may fail. *) Global_constants_storage.expand ctxt (strip_locations code) - >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code) + >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code) let parse_contract_data context loc arg_ty contract ~entrypoint = - parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint + parse_contract_data_aux ~stack_depth:0 context loc arg_ty contract ~entrypoint let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> - Lwt.return @@ parse_toplevel ctxt ~legacy toplevel + Lwt.return @@ parse_toplevel_aux ctxt ~legacy toplevel -let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 +let parse_comparable_ty = parse_comparable_ty_aux ~stack_depth:0 -let parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0 +let parse_big_map_value_ty = parse_big_map_value_ty_aux ~stack_depth:0 -let parse_packable_ty = parse_packable_ty ~stack_depth:0 +let parse_packable_ty = parse_packable_ty_aux ~stack_depth:0 -let parse_passable_ty = parse_passable_ty ~stack_depth:0 +let parse_passable_ty = parse_passable_ty_aux ~stack_depth:0 -let parse_any_ty = parse_any_ty ~stack_depth:0 +let parse_any_ty = parse_any_ty_aux ~stack_depth:0 -let parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints +let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = - parse_parameter_ty_and_entrypoints ~stack_depth:0 + parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 -let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = +let get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = - match kind with - | Lazy_storage.Kind.Sapling_state -> ( + match[@coq_match_gadt] (kind, id) with + | Lazy_storage.Kind.Sapling_state, (id : Sapling.Id.t) -> ( match single_id_opt with | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id) | Fold_lazy_storage.Ok (Some _) -> @@ -6086,31 +6239,31 @@ let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = (* - {!Script_cache} needs a measure of the script size in memory. - Determining this size is not easy in OCaml because of sharing. - - Indeed, many values present in the script share the same memory - area. This is especially true for types and stack types: they are - heavily shared in every typed IR internal representation. As a - consequence, computing the size of the typed IR without taking - sharing into account leads to a size which is sometimes two order - of magnitude bigger than the actual size. - - We could track down this sharing. Unfortunately, sharing is not - part of OCaml semantics: for this reason, a compiler can optimize - memory representation by adding more sharing. If two nodes use - different optimization flags or compilers, such a precise - computation of the memory footprint of scripts would lead to two - distinct sizes. As these sizes occur in the blockchain context, - this situation would lead to a fork. - - For this reason, we introduce a *size model* for the script size. - This model provides an overapproximation of the actual size in - memory. The risk is to be too far from the actual size: the cache - would then be wrongly marked as full. This situation would make the - cache less useful but should present no security risk . + {!Script_cache} needs a measure of the script size in memory. + Determining this size is not easy in OCaml because of sharing. + + Indeed, many values present in the script share the same memory + area. This is especially true for types and stack types: they are + heavily shared in every typed IR internal representation. As a + consequence, computing the size of the typed IR without taking + sharing into account leads to a size which is sometimes two order + of magnitude bigger than the actual size. + + We could track down this sharing. Unfortunately, sharing is not + part of OCaml semantics: for this reason, a compiler can optimize + memory representation by adding more sharing. If two nodes use + different optimization flags or compilers, such a precise + computation of the memory footprint of scripts would lead to two + distinct sizes. As these sizes occur in the blockchain context, + this situation would lead to a fork. + + For this reason, we introduce a *size model* for the script size. + This model provides an overapproximation of the actual size in + memory. The risk is to be too far from the actual size: the cache + would then be wrongly marked as full. This situation would make the + cache less useful but should present no security risk . -*) + *) let script_size (Ex_script (Script @@ -6130,5 +6283,5 @@ let script_size (Saturation_repr.(add code_size storage_size |> to_int), cost) let typecheck_code ~legacy ~show_types ctxt code = - typecheck_code ~legacy ~show_types ctxt code + typecheck_code_aux ~legacy ~show_types ctxt code >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt) diff --git a/src/proto_014_PtKathma/lib_protocol/script_ir_translator.mli b/src/proto_014_PtKathma/lib_protocol/script_ir_translator.mli index cd0e7a8e8bdd6..4097f3840d17c 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_ir_translator.mli +++ b/src/proto_014_PtKathma/lib_protocol/script_ir_translator.mli @@ -111,6 +111,7 @@ type ('arg, 'storage) code = field as it has a dynamic size. *) } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_code = Ex_code : ('a, 'c) code -> ex_code @@ -127,6 +128,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view +[@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) Script_typed_ir.map diff --git a/src/proto_014_PtKathma/lib_protocol/script_map.ml b/src/proto_014_PtKathma/lib_protocol/script_map.ml index 5e7dcf3b44da3..70f2c38f91f8d 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_map.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_map.ml @@ -44,18 +44,36 @@ let empty_from : type a b c. (a, b) map -> (a, c) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let empty : type a b. a comparable_ty -> (a, b) map = fun ty -> - let module OPS = struct + let module OPS : Boxed_map_OPS with type key = a = struct let key_size = Gas_comparable_input_size.size_of_comparable_value ty - include Map.Make (struct + module Map = Map.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type 'a t = 'a Map.t + + type key = Map.key + + let empty = Map.empty + + let add = Map.add + + let remove = Map.remove + + let find = Map.find + + let fold = Map.fold + + let fold_es = Map.fold_es end in Map_tag (module struct @@ -68,6 +86,8 @@ let empty : type a b. a comparable_ty -> (a, b) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let get : type key value. key -> (key, value) map -> value option = @@ -94,6 +114,8 @@ let update : type a b. a -> b option -> (a, b) map -> (a, b) map = let boxed = boxed let size = size + + let boxed_map_tag = () end) let mem : type key value. key -> (key, value) map -> bool = @@ -141,5 +163,7 @@ let map_es_in_context : let boxed = map let size = Box.size + + let boxed_map_tag = () end), ctxt ) diff --git a/src/proto_014_PtKathma/lib_protocol/script_repr.ml b/src/proto_014_PtKathma/lib_protocol/script_repr.ml index a730986fdd39b..ea9538318d568 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_repr.ml @@ -254,11 +254,13 @@ let force_decode_cost lexpr = ~fun_combine:(fun _ _ -> Gas_limit_repr.free) lexpr +type 'a bytes_or_value = Only_value of 'a | Has_bytes of bytes + let stable_force_decode_cost lexpr = let has_bytes = Data_encoding.apply_lazy - ~fun_value:(fun v -> `Only_value v) - ~fun_bytes:(fun b -> `Has_bytes b) + ~fun_value:(fun v -> Only_value v) + ~fun_bytes:(fun b -> Has_bytes b) ~fun_combine:(fun _v b -> (* When the lazy_expr contains both a deserialized version and a serialized one, we compute the cost from the @@ -267,8 +269,8 @@ let stable_force_decode_cost lexpr = lexpr in match has_bytes with - | `Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) - | `Only_value v -> + | Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) + | Only_value v -> (* This code path should not be reached in theory because values that are decoded should have been encoded before. Here we use Data_encoding.Binary.length, which yields the same results @@ -314,7 +316,7 @@ let is_unit_parameter = ~fun_bytes:(fun b -> Compare.Bytes.equal b unit_bytes) ~fun_combine:(fun res _ -> res) -let[@coq_struct "node"] rec strip_annotations node = +let[@coq_struct "node_value"] rec strip_annotations node = let open Micheline in match node with | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> leaf @@ -322,7 +324,7 @@ let[@coq_struct "node"] rec strip_annotations node = Prim (loc, name, List.map strip_annotations args, []) | Seq (loc, args) -> Seq (loc, List.map strip_annotations args) -let rec micheline_fold_aux node f acc k = +let rec micheline_fold_aux (node : _ michelson_node) f acc k = match node with | Micheline.Int (_, _) -> k (f acc node) | Micheline.String (_, _) -> k (f acc node) diff --git a/src/proto_014_PtKathma/lib_protocol/script_set.ml b/src/proto_014_PtKathma/lib_protocol/script_set.ml index c18824cdb973b..01ad398d0e5e9 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_set.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_set.ml @@ -36,11 +36,25 @@ let empty : type a. a comparable_ty -> a set = let module OPS : Boxed_set_OPS with type elt = a = struct let elt_size = Gas_comparable_input_size.size_of_comparable_value ty - include Set.Make (struct + module Set = Set.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type t = Set.t + + type elt = Set.elt + + let empty = Set.empty + + let add = Set.add + + let mem = Set.mem + + let remove = Set.remove + + let fold = Set.fold end in Set_tag (module struct diff --git a/src/proto_014_PtKathma/lib_protocol/script_string.ml b/src/proto_014_PtKathma/lib_protocol/script_string.ml index b3108eb31ef23..ea0c6bca872cc 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_string.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_string.ml @@ -57,7 +57,7 @@ let () = let empty = String_tag "" let of_string v = - let rec check_printable_ascii i = + let[@coq_struct "i_value"] rec check_printable_ascii i = if Compare.Int.(i < 0) then ok (String_tag v) else match v.[i] with diff --git a/src/proto_014_PtKathma/lib_protocol/script_tc_errors.ml b/src/proto_014_PtKathma/lib_protocol/script_tc_errors.ml index 1f0c39d222b8b..13c4404495e29 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_tc_errors.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_tc_errors.ml @@ -210,6 +210,6 @@ the error will be ignored later. For example, when types are compared during the interpretation of the [CONTRACT] instruction any error will lead to returning [None] but the content of the error will be ignored. *) -type (_, _) error_details = +type ('error_context, _) error_details = | Informative : 'error_context -> ('error_context, error trace) error_details - | Fast : (_, inconsistent_types_fast_error) error_details + | Fast : ('error_context, inconsistent_types_fast_error) error_details diff --git a/src/proto_014_PtKathma/lib_protocol/script_typed_ir.ml b/src/proto_014_PtKathma/lib_protocol/script_typed_ir.ml index 0dcc4420782b0..468536ef8be50 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_typed_ir.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_typed_ir.ml @@ -241,7 +241,7 @@ module type TYPE_SIZE = sig submodule), the type is abstract but we have access to unsafe constructors that can break the invariant. *) - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:('error_context, 'error_trace) Script_tc_errors.error_details -> @@ -296,7 +296,7 @@ module Type_size : TYPE_SIZE = struct if Compare.Int.(x = y) then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative _ -> trace_of_error @@ Script_tc_errors.Inconsistent_type_sizes (x, y)) @@ -399,6 +399,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end type ('key, 'value) map = @@ -440,6 +442,7 @@ and 'arg nested_entrypoints = } -> ('l, 'r) union nested_entrypoints | Entrypoints_None : _ nested_entrypoints +[@@coq_force_gadt] let no_entrypoints = {at_node = None; nested = Entrypoints_None} @@ -1116,6 +1119,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] and (_, _, _, _) continuation = | KNil : ('r, 'f, 'r, 'f) continuation @@ -1180,6 +1184,7 @@ and (_, _, _, _) continuation = | KLog : ('a, 's, 'r, 'f) continuation * ('a, 's) stack_ty * logger -> ('a, 's, 'r, 'f) continuation +[@@coq_force_gadt] and ('a, 's, 'b, 'f, 'c, 'u) logging_function = ('a, 's, 'b, 'f) kinstr -> @@ -1257,6 +1262,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty +[@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty @@ -1274,6 +1280,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1338,6 +1345,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction_to_contract : { @@ -1652,7 +1660,8 @@ let is_comparable : type v c. (v, c) ty -> c dbool = function | Chest_t -> No | Chest_key_t -> No -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] let unit_t = Unit_t @@ -1997,7 +2006,7 @@ let kinstr_traverse i init f = type 'a ty_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 'a} -let ty_traverse = +module Ty_traverse = struct let rec aux : type ret t tc accu. accu ty_traverse -> accu -> (t, tc) ty -> (accu -> ret) -> ret = @@ -2028,7 +2037,8 @@ let ty_traverse = (aux [@ocaml.tailcall]) f accu cty (fun accu -> (next [@ocaml.tailcall]) f accu ty1 continue) | Contract_t (ty1, _) -> (next [@ocaml.tailcall]) f accu ty1 continue - and next2 : + + and[@coq_mutual_as_notation] next2 : type a ac b bc ret accu. accu ty_traverse -> accu -> @@ -2040,14 +2050,16 @@ let ty_traverse = (aux [@ocaml.tailcall]) f accu ty1 (fun accu -> (aux [@ocaml.tailcall]) f accu ty2 (fun accu -> (continue [@ocaml.tailcall]) accu)) - and next : + + and[@coq_mutual_as_notation] next : type a ac ret accu. accu ty_traverse -> accu -> (a, ac) ty -> (accu -> ret) -> ret = fun f accu ty1 continue -> (aux [@ocaml.tailcall]) f accu ty1 (fun accu -> (continue [@ocaml.tailcall]) accu) - in - fun ty init f -> aux f init ty (fun accu -> accu) +end + +let ty_traverse ty init f = Ty_traverse.aux f init ty (fun accu -> accu) type 'accu stack_ty_traverse = { apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu; @@ -2064,78 +2076,104 @@ let stack_ty_traverse (type a t) (sty : (a, t) stack_ty) init f = type 'a value_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 't -> 'a} -let value_traverse (type t tc) (ty : (t, tc) ty) (x : t) init f = - let rec aux : type ret t tc. 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret +module Value_traverse = struct + let[@coq_struct "ty_value"] rec aux : + type ret t tc. + 'accu value_traverse -> 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret = - fun accu ty x continue -> + fun f accu ty x continue -> let accu = f.apply accu ty x in let next2 ty1 ty2 x1 x2 = - (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu -> - (aux [@ocaml.tailcall]) accu ty2 x2 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty1 x1 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty2 x2 (fun accu -> (continue [@ocaml.tailcall]) accu)) in let next ty1 x1 = - (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty1 x1 (fun accu -> (continue [@ocaml.tailcall]) accu) in let return () = (continue [@ocaml.tailcall]) accu in let rec on_list ty' accu = function | [] -> (continue [@ocaml.tailcall]) accu | x :: xs -> - (aux [@ocaml.tailcall]) accu ty' x (fun accu -> + (aux [@ocaml.tailcall]) f accu ty' x (fun accu -> (on_list [@ocaml.tailcall]) ty' accu xs) in - match ty with - | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t - | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t - | Bool_t | Sapling_transaction_t _ | Sapling_transaction_deprecated_t _ - | Sapling_state_t _ | Operation_t | Chain_id_t | Never_t | Bls12_381_g1_t - | Bls12_381_g2_t | Bls12_381_fr_t | Chest_key_t | Chest_t - | Lambda_t (_, _, _) -> + match[@coq_match_gadt] (ty, x) with + | Unit_t, _ + | Int_t, _ + | Nat_t, _ + | Signature_t, _ + | String_t, _ + | Bytes_t, _ + | Mutez_t, _ + | Key_hash_t, _ + | Key_t, _ + | Timestamp_t, _ + | Address_t, _ + | Tx_rollup_l2_address_t, _ + | Bool_t, _ + | Sapling_transaction_t _, _ + | Sapling_transaction_deprecated_t _, _ + | Sapling_state_t _, _ + | Operation_t, _ + | Chain_id_t, _ + | Never_t, _ + | Bls12_381_g1_t, _ + | Bls12_381_g2_t, _ + | Bls12_381_fr_t, _ + | Chest_key_t, _ + | Chest_t, _ + | Lambda_t (_, _, _), _ -> (return [@ocaml.tailcall]) () - | Pair_t (ty1, ty2, _, _) -> + | Pair_t (ty1, ty2, _, _), (x : _ * _) -> (next2 [@ocaml.tailcall]) ty1 ty2 (fst x) (snd x) - | Union_t (ty1, ty2, _, _) -> ( + | Union_t (ty1, ty2, _, _), (x : _ union) -> ( match x with | L l -> (next [@ocaml.tailcall]) ty1 l | R r -> (next [@ocaml.tailcall]) ty2 r) - | Option_t (ty, _, _) -> ( + | Option_t (ty, _, _), (x : _ option) -> ( match x with | None -> return () | Some v -> (next [@ocaml.tailcall]) ty v) - | Ticket_t (cty, _) -> (aux [@ocaml.tailcall]) accu cty x.contents continue - | List_t (ty', _) -> on_list ty' accu x.elements - | Map_t (kty, ty', _) -> + | Ticket_t (cty, _), (x : _ ticket) -> + (aux [@ocaml.tailcall]) f accu cty x.contents continue + | List_t (ty', _), (x : _ boxed_list) -> on_list ty' accu x.elements + | Map_t (kty, ty', _), (x : _ map) -> let (Map_tag (module M)) = x in let bindings = M.OPS.fold (fun k v bs -> (k, v) :: bs) M.boxed [] in - on_bindings accu kty ty' continue bindings - | Set_t (ty', _) -> + on_bindings f accu kty ty' continue bindings + | Set_t (ty', _), (x : _ set) -> let (Set_tag (module M)) = x in let elements = M.OPS.fold (fun x s -> x :: s) M.boxed [] in on_list ty' accu elements - | Big_map_t (_, _, _) -> + | Big_map_t (_, _, _), _ -> (* For big maps, there is no obvious recursion scheme so we delegate this case to the client. *) (return [@ocaml.tailcall]) () - | Contract_t (_, _) -> (return [@ocaml.tailcall]) () - and on_bindings : + | Contract_t (_, _), _ -> (return [@ocaml.tailcall]) () + + and[@coq_struct "xs"] on_bindings : type ret k v vc. + 'accu value_traverse -> 'accu -> k comparable_ty -> (v, vc) ty -> ('accu -> ret) -> (k * v) list -> ret = - fun accu kty ty' continue xs -> + fun f accu kty ty' continue xs -> match xs with | [] -> (continue [@ocaml.tailcall]) accu | (k, v) :: xs -> - (aux [@ocaml.tailcall]) accu kty k (fun accu -> - (aux [@ocaml.tailcall]) accu ty' v (fun accu -> - (on_bindings [@ocaml.tailcall]) accu kty ty' continue xs)) - in - aux init ty x (fun accu -> accu) - [@@coq_axiom_with_reason "local mutually recursive definition not handled"] + (aux [@ocaml.tailcall]) f accu kty k (fun accu -> + (aux [@ocaml.tailcall]) f accu ty' v (fun accu -> + (on_bindings [@ocaml.tailcall]) f accu kty ty' continue xs)) +end + +let value_traverse (type t tc) (ty : (t, tc) ty) (x : t) init f = + Value_traverse.aux f init ty x (fun accu -> accu) -let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = function +let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = + function[@coq_match_with_default] | Item_t (ty, _) -> Ty_ex_c ty diff --git a/src/proto_014_PtKathma/lib_protocol/script_typed_ir.mli b/src/proto_014_PtKathma/lib_protocol/script_typed_ir.mli index dc63790403709..382f8ab416d54 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_typed_ir.mli +++ b/src/proto_014_PtKathma/lib_protocol/script_typed_ir.mli @@ -174,7 +174,7 @@ type empty_cell = EmptyCell type end_of_stack = empty_cell * empty_cell module Type_size : sig - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:('error_context, 'error_trace) Script_tc_errors.error_details -> @@ -254,6 +254,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end (** [map] is made algebraic in order to distinguish it from the other type @@ -1117,6 +1119,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] (* @@ -1354,6 +1357,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty +[@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty @@ -1371,6 +1375,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1469,6 +1474,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction_to_contract : { @@ -1561,7 +1567,8 @@ val ty_size : ('a, _) ty -> 'a Type_size.t val is_comparable : ('v, 'c) ty -> 'c dbool -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] val unit_t : unit comparable_ty diff --git a/src/proto_014_PtKathma/lib_protocol/script_typed_ir_size.ml b/src/proto_014_PtKathma/lib_protocol/script_typed_ir_size.ml index 6a1fd023693fa..21a7852f7af4d 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_typed_ir_size.ml @@ -222,7 +222,7 @@ let chest_key_size _ = tail-recursive and the only recursive call that is not a tailcall cannot be nested. (See [big_map_size].) For this reason, these functions should not trigger stack overflows. *) -let rec value_size : +let[@coq_struct "ty_value"] rec value_size_aux : type a ac. count_lambda_nodes:bool -> nodes_and_size -> @@ -232,65 +232,79 @@ let rec value_size : fun ~count_lambda_nodes accu ty x -> let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size = fun accu ty x -> - match ty with - | Unit_t -> ret_succ accu - | Int_t -> ret_succ_adding accu (script_int_size x) - | Nat_t -> ret_succ_adding accu (script_nat_size x) - | Signature_t -> ret_succ_adding accu signature_size - | String_t -> ret_succ_adding accu (script_string_size x) - | Bytes_t -> ret_succ_adding accu (bytes_size x) - | Mutez_t -> ret_succ_adding accu mutez_size - | Key_hash_t -> ret_succ_adding accu (key_hash_size x) - | Key_t -> ret_succ_adding accu (public_key_size x) - | Timestamp_t -> ret_succ_adding accu (timestamp_size x) - | Address_t -> ret_succ_adding accu (address_size x) - | Tx_rollup_l2_address_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with + | Unit_t, _ -> ret_succ accu + | Int_t, (x : _ Script_int.num) -> ret_succ_adding accu (script_int_size x) + | Nat_t, (x : _ Script_int.num) -> ret_succ_adding accu (script_nat_size x) + | Signature_t, _ -> ret_succ_adding accu signature_size + | String_t, (x : Script_string.t) -> + ret_succ_adding accu (script_string_size x) + | Bytes_t, (x : bytes) -> ret_succ_adding accu (bytes_size x) + | Mutez_t, _ -> ret_succ_adding accu mutez_size + | Key_hash_t, (x : public_key_hash) -> + ret_succ_adding accu (key_hash_size x) + | Key_t, (x : public_key) -> ret_succ_adding accu (public_key_size x) + | Timestamp_t, (x : Script_timestamp.t) -> + ret_succ_adding accu (timestamp_size x) + | Address_t, (x : address) -> ret_succ_adding accu (address_size x) + | Tx_rollup_l2_address_t, (x : tx_rollup_l2_address) -> ret_succ_adding accu (tx_rollup_l2_address_size x) - | Bool_t -> ret_succ accu - | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w - | Union_t (_, _, _, _) -> ret_succ_adding accu h1w - | Lambda_t (_, _, _) -> - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x - | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) - | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length)) - | Set_t (_, _) -> - let module M = (val Script_set.get x) in + | Bool_t, _ -> ret_succ accu + | Pair_t (_, _, _, _), _ -> ret_succ_adding accu h2w + | Union_t (_, _, _, _), _ -> ret_succ_adding accu h1w + | Lambda_t (_, _, _), (x : _ lambda) -> + (lambda_size_aux [@ocaml.tailcall]) + ~count_lambda_nodes + (ret_succ accu) + x + | Option_t (_, _, _), (x : _ option) -> + ret_succ_adding accu (option_size (fun _ -> !!0) x) + | List_t (_, _), (x : _ boxed_list) -> + ret_succ_adding accu (h2w +! (h2w *? x.length)) + | Set_t (_, _), (x : _ set) -> + let set = Script_set.get x in + let module M = (val set) in let boxing_space = !!536 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h4w *? M.size)) - | Map_t (_, _, _) -> - let module M = (val Script_map.get_module x) in + | Map_t (_, _, _), (x : _ map) -> + let map = Script_map.get_module x in + let module M = (val map) in let boxing_space = !!696 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h5w *? M.size)) - | Big_map_t (cty, ty', _) -> - (big_map_size [@ocaml.tailcall]) + | Big_map_t (cty, ty', _), (x : _ big_map) -> + (big_map_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) cty ty' x - | Contract_t (_, _) -> ret_succ (accu ++ contract_size x) - | Sapling_transaction_t _ -> + | Contract_t (_, _), (x : _ typed_contract) -> + ret_succ (accu ++ contract_size x) + | Sapling_transaction_t _, (x : Sapling.transaction) -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) - | Sapling_transaction_deprecated_t _ -> + | Sapling_transaction_deprecated_t _, (x : Sapling_repr.legacy_transaction) + -> ret_succ_adding accu (Sapling.Legacy.transaction_in_memory_size x) - | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x) + | Sapling_state_t _, (x : Sapling.state) -> + ret_succ_adding accu (sapling_state_size x) (* Operations are neither storable nor pushable, so they can appear neither in the storage nor in the script. Hence they cannot appear in the cache and we never need to measure their size. *) - | Operation_t -> assert false - | Chain_id_t -> ret_succ_adding accu chain_id_size - | Never_t -> ( match x with _ -> .) - | Bls12_381_g1_t -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory - | Bls12_381_g2_t -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory - | Bls12_381_fr_t -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory - | Ticket_t (_, _) -> ret_succ_adding accu (ticket_size x) - | Chest_key_t -> ret_succ_adding accu (chest_key_size x) - | Chest_t -> ret_succ_adding accu (chest_size x) + | Operation_t, _ -> assert false + | Chain_id_t, _ -> ret_succ_adding accu chain_id_size + | Never_t, _ -> . + | Bls12_381_g1_t, _ -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory + | Bls12_381_g2_t, _ -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory + | Bls12_381_fr_t, _ -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory + | Ticket_t (_, _), (x : _ ticket) -> ret_succ_adding accu (ticket_size x) + | Chest_key_t, (x : Script_timelock.chest_key) -> + ret_succ_adding accu (chest_key_size x) + | Chest_t, (x : Script_timelock.chest) -> + ret_succ_adding accu (chest_size x) in value_traverse ty x accu {apply} - [@@coq_axiom_with_reason "unreachable expressions '.' not handled for now"] -and big_map_size : +and[@coq_mutual_as_notation] big_map_size_aux : type a b bc. count_lambda_nodes:bool -> nodes_and_size -> @@ -310,12 +324,16 @@ and big_map_size : (* The following recursive call cannot introduce a stack overflow because this would require a key of type big_map while big_map is not comparable. *) - let accu = value_size ~count_lambda_nodes accu cty key in + let accu = value_size_aux ~count_lambda_nodes accu cty key in match value with | None -> accu | Some value -> let accu = ret_succ_adding accu h1w in - (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu ty' value) + (value_size_aux [@ocaml.tailcall]) + ~count_lambda_nodes + accu + ty' + value) diff.map accu in @@ -327,7 +345,7 @@ and big_map_size : (ty_size key_type ++ ty_size value_type ++ diff_size) (h4w +! id_size) -and lambda_size : +and[@coq_struct "function_parameter"] lambda_size_aux : type i o. count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size = @@ -337,9 +355,9 @@ and lambda_size : let accu = ret_adding (accu ++ if count_lambda_nodes then node_size node else zero) h2w in - (kdescr_size [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr + (kdescr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr -and kdescr_size : +and[@coq_mutual_as_notation] kdescr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -349,9 +367,9 @@ and kdescr_size : let accu = ret_adding (accu ++ stack_ty_size kbef ++ stack_ty_size kaft) h4w in - (kinstr_size [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr + (kinstr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr -and kinstr_size : +and[@coq_struct "t_value"] kinstr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -384,7 +402,7 @@ and kinstr_size : | ISwap (loc, k) -> ret_succ_adding accu (base1 loc k) | IConst (loc, ty, x, k) -> let accu = ret_succ_adding accu (base1 loc k +! (word_size *? 2)) in - (value_size [@ocaml.tailcall]) + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (accu ++ ty_size ty) ty @@ -497,7 +515,7 @@ and kinstr_size : ret_succ_adding (accu ++ ty_size ty) (base1 loc k +! word_size) | ILambda (loc, lambda, k) -> let accu = ret_succ_adding accu (base1 loc k +! word_size) in - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes accu lambda + (lambda_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu lambda | IFailwith (loc, ty) -> ret_succ_adding (accu ++ ty_size ty) (base0 loc +! word_size) | ICompare (loc, cty, k) -> @@ -627,11 +645,11 @@ and kinstr_size : in kinstr_traverse t accu {apply} -let lambda_size lam = lambda_size ~count_lambda_nodes:true zero lam +let lambda_size lam = lambda_size_aux ~count_lambda_nodes:true zero lam -let kinstr_size kinstr = kinstr_size ~count_lambda_nodes:true zero kinstr +let kinstr_size kinstr = kinstr_size_aux ~count_lambda_nodes:true zero kinstr -let value_size ty x = value_size ~count_lambda_nodes:true zero ty x +let value_size ty x = value_size_aux ~count_lambda_nodes:true zero ty x module Internal_for_tests = struct let ty_size = ty_size diff --git a/src/proto_014_PtKathma/lib_protocol/seed_repr.ml b/src/proto_014_PtKathma/lib_protocol/seed_repr.ml index 23dc8fe39f521..6855f933e0610 100644 --- a/src/proto_014_PtKathma/lib_protocol/seed_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/seed_repr.ml @@ -140,7 +140,7 @@ let take_int32 s bound = let drop_if_over = Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let bytes, s = take s in let r = TzEndian.get_int32 bytes 0 in (* The absolute value of min_int is min_int. Also, every @@ -163,7 +163,7 @@ let take_int64 s bound = Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let bytes, s = take s in let r = TzEndian.get_int64 bytes 0 in (* The absolute value of min_int is min_int. Also, every @@ -215,7 +215,7 @@ let initial_nonce_hash_0 = hash initial_nonce_0 let deterministic_seed seed = update_seed seed zero_bytes let initial_seeds ?initial_seed n = - let[@coq_struct "i"] rec loop acc elt i = + let[@coq_struct "i_value"] rec loop acc elt i = if Compare.Int.(i = 1) then List.rev (elt :: acc) else loop (elt :: acc) (deterministic_seed elt) (i - 1) in diff --git a/src/proto_014_PtKathma/lib_protocol/services_registration.ml b/src/proto_014_PtKathma/lib_protocol/services_registration.ml index de94c5dbdf695..4fa5d81a2d9c3 100644 --- a/src/proto_014_PtKathma/lib_protocol/services_registration.ml +++ b/src/proto_014_PtKathma/lib_protocol/services_registration.ml @@ -31,12 +31,14 @@ type rpc_context = { context : Alpha_context.t; } +type level = Head_level | Successor_level + let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) mode = let timestamp = block_header.timestamp in let level = match mode with - | `Head_level -> block_header.level - | `Successor_level -> Int32.succ block_header.level + | Head_level -> block_header.level + | Successor_level -> Int32.succ block_header.level in Alpha_context.prepare ~level @@ -51,7 +53,7 @@ let rpc_services = let register0_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -63,7 +65,7 @@ let register0_noctxt ~chunked s f = let register1_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -75,7 +77,7 @@ let register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -84,7 +86,7 @@ let register2 ~chunked s f = let opt_register0_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = opt_register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -92,7 +94,7 @@ let opt_register0 ~chunked s f = let opt_register1_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let opt_register1 ~chunked s f = opt_register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -104,7 +106,7 @@ let opt_register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let opt_register2 ~chunked s f = opt_register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -114,7 +116,7 @@ let get_rpc_services () = let p = RPC_directory.map (fun c -> - rpc_init c `Head_level >|= function + rpc_init c Head_level >|= function | Error t -> raise (Failure (Format.asprintf "%a" Error_monad.pp_trace t)) | Ok c -> c.context) diff --git a/src/proto_014_PtKathma/lib_protocol/services_registration.mli b/src/proto_014_PtKathma/lib_protocol/services_registration.mli index c6bc2ed72c92a..da7faca5500a2 100644 --- a/src/proto_014_PtKathma/lib_protocol/services_registration.mli +++ b/src/proto_014_PtKathma/lib_protocol/services_registration.mli @@ -44,6 +44,8 @@ type rpc_context = { context : t; } +type level = Head_level | Successor_level + (** [rpc_init rpc_context mode] allows to instantiate an [rpc_context] using the [Alpha_context] representation from a raw context representation (the one the shell knows). @@ -60,9 +62,7 @@ type rpc_context = { paths depend on the level. Using the successor level allows to ensure that the simulation is done on a fresh level. *) val rpc_init : - Updater.rpc_context -> - [`Head_level | `Successor_level] -> - rpc_context Error_monad.tzresult Lwt.t + Updater.rpc_context -> level -> rpc_context Error_monad.tzresult Lwt.t val register0 : chunked:bool -> diff --git a/src/proto_014_PtKathma/lib_protocol/skip_list_repr.ml b/src/proto_014_PtKathma/lib_protocol/skip_list_repr.ml index cc65a1d5e6e67..baad3719ada5b 100644 --- a/src/proto_014_PtKathma/lib_protocol/skip_list_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/skip_list_repr.ml @@ -38,7 +38,7 @@ module type S = sig 'content Data_encoding.t -> ('content, 'ptr) cell Data_encoding.t - val index : (_, _) cell -> int + val index : ('content, 'ptr) cell -> int val content : ('content, 'ptr) cell -> 'content @@ -69,9 +69,11 @@ module type S = sig bool end -module Make (Parameters : sig +module type S_Parameters = sig val basis : int -end) : S = struct +end + +module Make (Parameters : S_Parameters) : S = struct let () = assert (Compare.Int.(Parameters.basis >= 2)) open Parameters @@ -170,7 +172,7 @@ end) : S = struct let next ~prev_cell ~prev_cell_ptr content = let index = prev_cell.index + 1 in let back_pointers = - let rec aux power accu i = + let[@coq_struct "power"] rec aux power accu i = if Compare.Int.(index < power) then List.rev accu else let back_pointer_i = @@ -194,7 +196,7 @@ end) : S = struct let best_skip cell target_index = let index = cell.index in - let rec aux idx pow best_idx = + let[@coq_struct "idx"] rec aux idx pow best_idx = if Compare.Int.(idx >= FallbackArray.length cell.back_pointers) then best_idx else @@ -205,7 +207,7 @@ end) : S = struct aux 0 1 None let back_path ~deref ~cell_ptr ~target_index = - let rec aux path ptr = + let[@coq_struct "ptr"] rec aux path ptr = let path = ptr :: path in Option.bind (deref ptr) @@ fun cell -> let index = cell.index in @@ -220,7 +222,7 @@ end) : S = struct let mem equal x l = let open FallbackArray in let n = length l in - let rec aux idx = + let[@coq_struct "idx"] rec aux idx = if Compare.Int.(idx >= n) then false else match FallbackArray.get l idx with @@ -235,7 +237,7 @@ end) : S = struct assume_some (deref target_ptr) @@ fun target -> assume_some (deref cell_ptr) @@ fun cell -> let target_index = index target and cell_index = index cell in - let rec valid_path index cell_ptr path = + let[@coq_struct "path"] rec valid_path index cell_ptr path = match (cell_ptr, path) with | final_cell, [] -> equal_ptr target_ptr final_cell && Compare.Int.(index = target_index) diff --git a/src/proto_014_PtKathma/lib_protocol/skip_list_repr.mli b/src/proto_014_PtKathma/lib_protocol/skip_list_repr.mli index 843003e18a151..88c52825bd5ef 100644 --- a/src/proto_014_PtKathma/lib_protocol/skip_list_repr.mli +++ b/src/proto_014_PtKathma/lib_protocol/skip_list_repr.mli @@ -112,6 +112,8 @@ module type S = sig bool end -module Make (_ : sig +module type S_Parameters = sig val basis : int -end) : S +end + +module Make (_ : S_Parameters) : S diff --git a/src/proto_014_PtKathma/lib_protocol/slot_repr.ml b/src/proto_014_PtKathma/lib_protocol/slot_repr.ml index 4cb7219bfedc2..338df1a6d3e22 100644 --- a/src/proto_014_PtKathma/lib_protocol/slot_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/slot_repr.ml @@ -84,21 +84,21 @@ module Range = struct ok (Interval {lo = min; hi = max}) let fold f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then acc else loop ~acc:(f acc next) ~next:(next + 1) in loop ~acc:(f init lo) ~next:(lo + 1) let fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next + 1) in f init lo >>=? fun acc -> loop ~acc ~next:(lo + 1) let rev_fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next < lo) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next - 1) in diff --git a/src/proto_014_PtKathma/lib_protocol/storage.ml b/src/proto_014_PtKathma/lib_protocol/storage.ml index 064797d6476b5..a3b53d32c3314 100644 --- a/src/proto_014_PtKathma/lib_protocol/storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/storage.ml @@ -93,7 +93,7 @@ module type Simple_single_data_storage = sig end module Block_round : Simple_single_data_storage with type value = Round_repr.t = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["block_round"] end) @@ -101,7 +101,7 @@ module Block_round : Simple_single_data_storage with type value = Round_repr.t = module Tenderbake = struct module First_level_of_protocol = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["first_level_of_protocol"] end) @@ -118,14 +118,14 @@ module Tenderbake = struct end module Endorsement_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["endorsement_branch"] end) (Branch) module Grand_parent_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["grand_parent_branch"] end) @@ -164,7 +164,7 @@ end module Contract = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["contracts"] end) @@ -390,7 +390,7 @@ module Global_constants = struct and type key = Script_expr_hash.t and type value = Script_repr.expr = Make_indexed_carbonated_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["global_constant"] end)) @@ -408,7 +408,7 @@ module Big_map = struct type id = Lazy_storage_kind.Big_map.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["big_maps"] end) @@ -543,7 +543,7 @@ module Sapling = struct type id = Lazy_storage_kind.Sapling_state.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sapling"] end) @@ -899,7 +899,7 @@ end module Delegates = Make_data_set_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["delegates"] end)) @@ -925,7 +925,7 @@ end module Cycle = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["cycle"] end)) @@ -1040,7 +1040,7 @@ module Slashed_deposits = Cycle.Slashed_deposits module Stake = struct module Staking_balance = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["staking_balance"] end)) @@ -1050,7 +1050,7 @@ module Stake = struct module Active_delegate_with_one_roll = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["active_delegate_with_one_roll"] end)) @@ -1081,7 +1081,7 @@ module Stake = struct The ratio [blocks_per_cycle / blocks_per_stake_snapshot] above is checked in {!val:Constants_repr.check_constants} to fit in a UInt16. *) module Last_snapshot = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["last_snapshot"] end) @@ -1095,7 +1095,7 @@ module Delegate_sampler_state = Cycle.Delegate_sampler_state module Vote = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["votes"] end) @@ -1301,7 +1301,7 @@ end module Commitments = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["commitments"] end)) @@ -1319,7 +1319,7 @@ module Ramp_up = struct module Rewards = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["ramp_up"; "rewards"] end)) @@ -1355,7 +1355,7 @@ end module Pending_migration = struct module Balance_updates = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_balance_updates"] end) @@ -1366,7 +1366,7 @@ module Pending_migration = struct end) module Operation_results = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_operation_results"] end) @@ -1401,7 +1401,7 @@ end module Liquidity_baking = struct module Toggle_ema = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct (* The old "escape" name is kept here to avoid migrating this. *) let name = ["liquidity_baking_escape_ema"] @@ -1409,7 +1409,7 @@ module Liquidity_baking = struct (Encoding.Int32) module Cpmm_address = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["liquidity_baking_cpmm_address"] end) @@ -1426,7 +1426,7 @@ module Ticket_balance = struct let name = ["ticket_balance"] end - module Raw_context = Make_subcontext (Registered) (Raw_context) (Name) + module Raw_context = Make_subcontext (Registered) (Raw_context.M) (Name) module Paid_storage_space = Make_single_data_storage (Registered) (Raw_context) @@ -1449,14 +1449,19 @@ module Ticket_balance = struct end) module Index = Make_index (Ticket_hash_repr.Index) - module Table = + + module Table : + Non_iterable_indexed_carbonated_data_storage + with type t := Raw_context.t + and type key = Ticket_hash_repr.t + and type value = Z.t = Make_indexed_carbonated_data_storage (Table_context) (Index) (Encoding.Z) end module Tx_rollup = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["tx_rollup"] end)) @@ -1524,7 +1529,7 @@ end module Sc_rollup = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sc_rollup"] end) @@ -1662,7 +1667,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_commitment_repr.Hash.encoding end) - module Stakers = + module Stakers : + Non_iterable_indexed_carbonated_data_storage + with type key = Signature.Public_key_hash.t + and type value = Sc_rollup_commitment_repr.Hash.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1704,7 +1713,11 @@ module Sc_rollup = struct include Make_versioned (Sc_rollup_commitment_repr) (Commitments_versioned) end - module Commitment_stake_count = + module Commitment_stake_count : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = int32 + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1717,7 +1730,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitment_added = + module Commitment_added : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = Raw_level_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1761,7 +1778,11 @@ module Sc_rollup = struct let encoding = Raw_level_repr.encoding end) - module Opponent = + module Opponent : + Non_iterable_indexed_carbonated_data_storage + with type key = Signature.Public_key_hash.t + and type value = Sc_rollup_repr.Staker.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1879,7 +1900,11 @@ module Dal = struct This is only for prototyping. Probably something smarter would be to index each header directly. *) - module Slot_headers = + module Slot_headers : + Non_iterable_indexed_data_storage + with type t = Raw_context.t + and type key = Raw_level_repr.t + and type value = Dal_slot_repr.slot list = Level_context.Make_map (struct let name = ["slots"] diff --git a/src/proto_014_PtKathma/lib_protocol/storage_description.ml b/src/proto_014_PtKathma/lib_protocol/storage_description.ml index 86aed867ac161..6e28de43fdeb8 100644 --- a/src/proto_014_PtKathma/lib_protocol/storage_description.ml +++ b/src/proto_014_PtKathma/lib_protocol/storage_description.ml @@ -124,26 +124,28 @@ type (_, _, _) args = ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args -let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function +let[@coq_struct "function_parameter"] rec unpack : + type a b c. (a, b, c) args -> c -> a * b = + function[@coq_match_gadt_with_result] | One _ -> fun x -> x | Pair (l, r) -> - let unpack_l = unpack l in - let unpack_r = unpack r in + let unpack_l = (unpack [@coq_type_annotation]) l in + let unpack_r = (unpack [@coq_type_annotation]) r in fun x -> let c, d = unpack_r x in let b, a = unpack_l c in (b, (a, d)) - [@@coq_axiom_with_reason "gadt"] -let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function +let[@coq_struct "function_parameter"] rec pack : + type a b c. (a, b, c) args -> a -> b -> c = + function[@coq_match_gadt_with_result] | One _ -> fun b a -> (b, a) | Pair (l, r) -> - let pack_l = pack l in - let pack_r = pack r in + let pack_l = (pack [@coq_type_annotation]) l in + let pack_r = (pack [@coq_type_annotation]) r in fun b (a, d) -> let c = pack_l b a in pack_r c d - [@@coq_axiom_with_reason "gadt"] let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function | One {compare; _} -> compare diff --git a/src/proto_014_PtKathma/lib_protocol/storage_functors.ml b/src/proto_014_PtKathma/lib_protocol/storage_functors.ml index d32d3f00c4562..c0deb0c3fa4a9 100644 --- a/src/proto_014_PtKathma/lib_protocol/storage_functors.ml +++ b/src/proto_014_PtKathma/lib_protocol/storage_functors.ml @@ -115,7 +115,6 @@ module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : let config t = C.config t module Tree = C.Tree - module Proof = C.Proof let verify_tree_proof = C.verify_tree_proof @@ -249,7 +248,9 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc -> match C.Tree.kind tree with | `Value -> ( - match I.of_path file with None -> assert false | Some p -> f p acc) + match I.of_path file with + | None -> Lwt.return acc + | Some p -> f p acc) | `Tree -> Lwt.return acc) let elements s = @@ -321,7 +322,7 @@ struct C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> ( let key () = C.absolute_key s file in match of_bytes ~key v with @@ -497,7 +498,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL else (* Nominal case *) match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some key -> get_unprojected s key >|=? fun (s, value) -> (s, value :: rev_values, 0, pred length)) @@ -520,9 +521,9 @@ module Make_indexed_carbonated_data_storage_INTERNAL | last :: rest when Compare.String.(last = data_name) -> ( let file = List.rev rest in match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) - | _ -> assert false) + | _ -> Lwt.return acc) | `Tree -> Lwt.return acc) let keys_unaccounted s = @@ -642,7 +643,7 @@ module Make_indexed_data_snapshotable_storage C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> return acc | Some path -> ( let key () = C.absolute_key s file in match V_encoder.of_bytes ~key v with @@ -674,7 +675,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : match C.Tree.kind tree with | `Tree -> ( match I.of_path path with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) | `Value -> Lwt.return acc) @@ -795,8 +796,6 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : C.Tree.empty t end - module Proof = C.Proof - let verify_tree_proof = C.verify_tree_proof let verify_stream_proof = C.verify_stream_proof diff --git a/src/proto_014_PtKathma/lib_protocol/ticket_accounting.ml b/src/proto_014_PtKathma/lib_protocol/ticket_accounting.ml index 64c2273f18fd5..56b8cc6f7d881 100644 --- a/src/proto_014_PtKathma/lib_protocol/ticket_accounting.ml +++ b/src/proto_014_PtKathma/lib_protocol/ticket_accounting.ml @@ -58,7 +58,7 @@ module Ticket_token_map = struct Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) >|? fun ctxt -> (Z.add b1 b2, ctxt) - let of_list ctxt token_amounts = + let of_list_with_merge ctxt token_amounts = Ticket_token_map.of_list ctxt ~merge_overlap token_amounts let add ctxt = Ticket_token_map.merge ctxt ~merge_overlap @@ -88,9 +88,9 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = >|? fun ctxt -> ((token, Script_int.to_zint amount) :: acc, ctxt)) ([], ctxt) tickets - >>?= fun (list, ctxt) -> Ticket_token_map.of_list ctxt list + >>?= fun (list, ctxt) -> Ticket_token_map.of_list_with_merge ctxt list -let update_ticket_balances ctxt ~total_storage_diff token destinations = +let update_ticket_balances_raw ctxt ~total_storage_diff token destinations = List.fold_left_es (fun (tot_storage_diff, ctxt) (owner, delta) -> Ticket_balance_key.of_ex_token ctxt ~owner token @@ -122,7 +122,7 @@ let update_ticket_balances_for_self_contract ctxt ~self ticket_diffs = is_valid_balance_update (invalid_ticket_transfer_error ~ticket_token ~amount) >>?= fun () -> - update_ticket_balances + update_ticket_balances_raw ctxt ~total_storage_diff ticket_token @@ -137,7 +137,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt lazy_storage_diff - >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list ctxt diffs + >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list_with_merge ctxt diffs else return (Ticket_token_map.empty, ctxt) (* TODO #2465 @@ -250,6 +250,10 @@ let update_ticket_balances ctxt ~self ~ticket_diffs operations = ([], ctxt) destinations >>?= fun (destinations, ctxt) -> - update_ticket_balances ctxt ~total_storage_diff ticket_token destinations) + update_ticket_balances_raw + ctxt + ~total_storage_diff + ticket_token + destinations) (total_storage_diff, ctxt) ticket_op_diffs diff --git a/src/proto_014_PtKathma/lib_protocol/ticket_hash_builder.ml b/src/proto_014_PtKathma/lib_protocol/ticket_hash_builder.ml index fc7f79181e183..1fdc9e9245dc1 100644 --- a/src/proto_014_PtKathma/lib_protocol/ticket_hash_builder.ml +++ b/src/proto_014_PtKathma/lib_protocol/ticket_hash_builder.ml @@ -41,11 +41,11 @@ let () = (fun () -> Failed_to_hash_node) let hash_bytes_cost bytes = - let module S = Saturation_repr in - let ( + ) = S.add in - let v0 = S.safe_int @@ Bytes.length bytes in - let ( lsr ) = S.shift_right in - S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost + let ( + ) = Saturation_repr.add in + let v0 = Saturation_repr.safe_int @@ Bytes.length bytes in + let ( lsr ) = Saturation_repr.shift_right in + Saturation_repr.safe_int 200 + (v0 + (v0 lsr 2)) + |> Gas_limit_repr.atomic_step_cost let hash_of_node ctxt node = Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node) diff --git a/src/proto_014_PtKathma/lib_protocol/ticket_hash_repr.ml b/src/proto_014_PtKathma/lib_protocol/ticket_hash_repr.ml index 21c1869114041..274f6366f3219 100644 --- a/src/proto_014_PtKathma/lib_protocol/ticket_hash_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/ticket_hash_repr.ml @@ -23,16 +23,33 @@ (* *) (*****************************************************************************) -include Script_expr_hash +type t = Script_expr_hash.t -let of_script_expr_hash t = t +let encoding = Script_expr_hash.encoding + +let pp = Script_expr_hash.pp + +let to_b58check = Script_expr_hash.to_b58check + +let of_b58check_opt = Script_expr_hash.of_b58check_opt + +let of_b58check_exn = Script_expr_hash.of_b58check_exn -let zero = zero +let of_bytes_exn = Script_expr_hash.of_bytes_exn + +let of_bytes_opt = Script_expr_hash.of_bytes_opt include Compare.Make (struct - type nonrec t = t + type nonrec t = Script_expr_hash.t - let compare = compare + let compare = Script_expr_hash.compare end) -module Index = Script_expr_hash +let zero = Script_expr_hash.zero + +let of_script_expr_hash t = t + +module Index : Storage_description.INDEX with type t = Script_expr_hash.t = +struct + include Script_expr_hash +end diff --git a/src/proto_014_PtKathma/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_014_PtKathma/lib_protocol/ticket_lazy_storage_diff.ml index d2aaa66055fcd..d11752cc0615e 100644 --- a/src/proto_014_PtKathma/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_014_PtKathma/lib_protocol/ticket_lazy_storage_diff.ml @@ -76,7 +76,7 @@ let parse_value_type ctxt value_type = removing a value containing tickets. *) let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc = - Ticket_scanner.tickets_of_node + (Ticket_scanner.tickets_of_node [@coq_implicit "a" "a"]) ctxt (* It's currently not possible to have nested lazy structures, but this is for future proofing. *) @@ -120,7 +120,7 @@ let collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets = match expr_opt with | Some expr -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "a" "a"]) ctxt has_tickets expr @@ -174,12 +174,12 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates We should have the non-serialized version of the value type. *) parse_value_type ctxt value_type - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> List.fold_left_es (fun (acc, already_updated, ctxt) update -> - collect_token_diffs_of_big_map_update + (collect_token_diffs_of_big_map_update [@coq_implicit "a" "__Ex_ty_'a"]) ctxt ~big_map_id has_tickets @@ -204,7 +204,8 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = type. It would be more efficient if the value preserved. *) parse_value_type ctxt value_ty - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) + -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> (* Iterate over big-map items. *) @@ -216,7 +217,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = Big_map.list_values ctxt big_map_id >>=? fun (ctxt, exprs) -> List.fold_left_es (fun (acc, ctxt) node -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "a" "__Ex_ty_'a"]) ctxt has_tickets node @@ -247,15 +248,23 @@ let collect_token_diffs_of_big_map_and_updates ctxt big_map_id updates acc = let collect_token_diffs_of_big_map_diff ctxt diff_item acc = Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step >>?= fun ctxt -> - match diff_item with - | Lazy_storage.Item (Lazy_storage_kind.Big_map, big_map_id, Remove) -> + match[@coq_match_gadt] diff_item with + | Lazy_storage.Item + (Lazy_storage_kind.Big_map, (big_map_id : Big_map.Id.t), Remove) -> (* Collect all removed tokens from the big-map. *) collect_token_diffs_of_big_map ctxt ~get_token_and_amount:neg_token_and_amount big_map_id acc - | Item (Lazy_storage_kind.Big_map, big_map_id, Update {init; updates}) -> ( + | Item + ( Lazy_storage_kind.Big_map, + (big_map_id : Big_map.Id.t), + (Update {init; updates} : + ( Big_map.Id.t, + Lazy_storage_kind.Big_map.alloc, + Lazy_storage_kind.Big_map.updates ) + Lazy_storage.diff) ) -> ( match init with | Lazy_storage.Existing -> (* Collect token diffs from the updates to the big-map. *) diff --git a/src/proto_014_PtKathma/lib_protocol/ticket_scanner.ml b/src/proto_014_PtKathma/lib_protocol/ticket_scanner.ml index 992f01194c778..67be20314fbe2 100644 --- a/src/proto_014_PtKathma/lib_protocol/ticket_scanner.ml +++ b/src/proto_014_PtKathma/lib_protocol/ticket_scanner.ml @@ -120,7 +120,7 @@ module Ticket_inspection = struct a Script_typed_ir.comparable_ty -> (a has_tickets -> ret) -> ret = fun key_ty k -> let open Script_typed_ir in - match key_ty with + match[@coq_match_with_default] key_ty with | Unit_t -> (k [@ocaml.tailcall]) False_ht | Never_t -> (k [@ocaml.tailcall]) False_ht | Int_t -> (k [@ocaml.tailcall]) False_ht @@ -155,7 +155,7 @@ module Ticket_inspection = struct The returned value matches the given shape of the [ty] value, except it collapses whole branches where no types embed tickets to [False_ht]. *) - let rec has_tickets_of_ty : + let rec has_tickets_of_ty_aux : type a ac ret. (a, ac) Script_typed_ir.ty -> (a, ret) continuation -> ret tzresult = fun ty k -> @@ -192,11 +192,11 @@ module Ticket_inspection = struct a packable type and tickets are not packable. *) (k [@ocaml.tailcall]) False_ht | Option_t (ty, _, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let opt_hty = map_has_tickets (fun ht -> Option_ht ht) ht in (k [@ocaml.tailcall]) opt_hty) | List_t (ty, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let list_hty = map_has_tickets (fun ht -> List_ht ht) ht in (k [@ocaml.tailcall]) list_hty) | Set_t (key_ty, _) -> @@ -231,7 +231,7 @@ module Ticket_inspection = struct | Chest_t -> (k [@ocaml.tailcall]) False_ht | Chest_key_t -> (k [@ocaml.tailcall]) False_ht - and has_tickets_of_pair : + and[@coq_mutual_as_notation] has_tickets_of_pair : type a ac b bc c ret. (a, ac) Script_typed_ir.ty -> (b, bc) Script_typed_ir.ty -> @@ -239,11 +239,11 @@ module Ticket_inspection = struct (c, ret) continuation -> ret tzresult = fun ty1 ty2 ~pair k -> - (has_tickets_of_ty [@ocaml.tailcall]) ty1 (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) ty2 (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty1 (fun ht1 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty2 (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) - and has_tickets_of_key_and_value : + and[@coq_mutual_as_notation] has_tickets_of_key_and_value : type k v vc t ret. k Script_typed_ir.comparable_ty -> (v, vc) Script_typed_ir.ty -> @@ -252,12 +252,12 @@ module Ticket_inspection = struct ret tzresult = fun key_ty val_ty ~pair k -> (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) val_ty (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) val_ty (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) let has_tickets_of_ty ctxt ty = Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) >>? fun ctxt -> - has_tickets_of_ty ty ok >|? fun ht -> (ht, ctxt) + has_tickets_of_ty_aux ty ok >|? fun ht -> (ht, ctxt) end module Ticket_collection = struct @@ -285,7 +285,7 @@ module Ticket_collection = struct ret tzresult Lwt.t = fun ctxt comp_ty acc k -> let open Script_typed_ir in - match comp_ty with + match[@coq_match_with_default] comp_ty with | Unit_t -> (k [@ocaml.tailcall]) ctxt acc | Never_t -> (k [@ocaml.tailcall]) ctxt acc | Int_t -> (k [@ocaml.tailcall]) ctxt acc @@ -319,7 +319,7 @@ module Ticket_collection = struct comparable. *) (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc k - let rec tickets_of_value : + let[@coq_axiom_with_reason "gadts"] rec tickets_of_value_aux : type a ac ret. include_lazy:bool -> allow_zero_amount_tickets:bool -> @@ -337,7 +337,7 @@ module Ticket_collection = struct | False_ht, _ -> (k [@ocaml.tailcall]) ctxt acc | Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _) -> let l, r = x in - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -346,7 +346,7 @@ module Ticket_collection = struct l acc (fun ctxt acc -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -358,7 +358,7 @@ module Ticket_collection = struct | Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _) -> ( match x with | L v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -368,7 +368,7 @@ module Ticket_collection = struct acc k | R v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -380,7 +380,7 @@ module Ticket_collection = struct | Option_ht el_hty, Option_t (el_ty, _, _) -> ( match x with | Some x -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -437,7 +437,7 @@ module Ticket_collection = struct Forbidden_zero_ticket_quantity >>=? fun () -> (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) - and tickets_of_list : + and[@coq_axiom_with_reason "gadts"] tickets_of_list : type a ac ret. context -> include_lazy:bool -> @@ -452,7 +452,7 @@ module Ticket_collection = struct consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> match elements with | elem :: elems -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -472,7 +472,7 @@ module Ticket_collection = struct k) | [] -> (k [@ocaml.tailcall]) ctxt acc - and tickets_of_map : + and[@coq_axiom_with_reason "gadts"] tickets_of_map : type k v vc ret. include_lazy:bool -> allow_zero_amount_tickets:bool -> @@ -499,7 +499,7 @@ module Ticket_collection = struct acc k - and tickets_of_big_map : + and[@coq_axiom_with_reason "gadts"] tickets_of_big_map : type k v ret. context -> allow_zero_amount_tickets:bool -> @@ -549,7 +549,7 @@ module Ticket_collection = struct | None -> (k [@ocaml.tailcall]) ctxt acc) let tickets_of_value ctxt ~include_lazy ht ty x = - tickets_of_value ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> + tickets_of_value_aux ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> return (ex_tickets, ctxt)) end @@ -557,6 +557,7 @@ type 'a has_tickets = | Has_tickets : 'a Ticket_inspection.has_tickets * ('a, _) Script_typed_ir.ty -> 'a has_tickets +[@@coq_force_gadt] let type_has_tickets ctxt ty = Ticket_inspection.has_tickets_of_ty ctxt ty >|? fun (has_tickets, ctxt) -> @@ -579,8 +580,8 @@ let tickets_of_node ctxt ~include_lazy ~allow_zero_amount_tickets has_tickets let (Has_tickets (ht, ty)) = has_tickets in match ht with | Ticket_inspection.False_ht -> return ([], ctxt) - | _ -> - Script_ir_translator.parse_data + | (_ : _ Ticket_inspection.has_tickets) -> + (Script_ir_translator.parse_data [@coq_implicit "A" "a"]) ctxt ~legacy:true ~allow_forged:true diff --git a/src/proto_014_PtKathma/lib_protocol/ticket_scanner.mli b/src/proto_014_PtKathma/lib_protocol/ticket_scanner.mli index bb6be0d5e8506..8e10ed37e4ebe 100644 --- a/src/proto_014_PtKathma/lib_protocol/ticket_scanner.mli +++ b/src/proto_014_PtKathma/lib_protocol/ticket_scanner.mli @@ -41,7 +41,7 @@ type ex_ticket = (** A type-witness that contains information about which branches of a type ['a] include tickets. This value is used for traversing only the relevant branches of values when scanning for tickets. *) -type 'a has_tickets +type 'a has_tickets [@@coq_phantom] (** [type_has_tickets ctxt ty] returns a [has_tickets] witness of the given shape [ty]. diff --git a/src/proto_014_PtKathma/lib_protocol/token.ml b/src/proto_014_PtKathma/lib_protocol/token.ml index 6e1de3ef52308..a326919d09f10 100644 --- a/src/proto_014_PtKathma/lib_protocol/token.ml +++ b/src/proto_014_PtKathma/lib_protocol/token.ml @@ -24,71 +24,73 @@ (*****************************************************************************) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments + | Burned -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container let allocated ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.exists ctxt bpkh >|= fun allocated -> ok (ctxt, allocated) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Contract_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.Implicit delegate in Frozen_deposits_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Block_fees -> return (ctxt, true) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, true) + | Frozen_bonds (contract, bond_id) -> Contract_storage.bond_allocated ctxt contract bond_id let balance ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.get_balance ctxt contract >|=? fun balance -> (ctxt, balance) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.committed_amount ctxt bpkh >|=? fun balance -> (ctxt, balance) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Storage.Contract.Spendable_balance.get ctxt contract >|=? fun balance -> (ctxt, balance) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.Implicit delegate in Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits -> let balance = @@ -97,45 +99,45 @@ let balance ctxt stored = | Some frozen_deposits -> frozen_deposits.current_amount in (ctxt, balance) - | `Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) + | Frozen_bonds (contract, bond_id) -> Contract_storage.find_bond ctxt contract bond_id >|=? fun (ctxt, balance_opt) -> (ctxt, Option.value ~default:Tez_repr.zero balance_opt) -let credit ctxt dest amount origin = +let credit ctxt (dest : sink) amount origin = let open Receipt_repr in (match dest with - | #infinite_sink as infinite_sink -> + | Sink_infinite infinite_sink -> let sink = match infinite_sink with - | `Storage_fees -> Storage_fees - | `Double_signing_punishments -> Double_signing_punishments - | `Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) - | `Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments -> Sc_rollup_refutation_punishments - | `Burned -> Burned + | Storage_fees -> Storage_fees + | Double_signing_punishments -> Double_signing_punishments + | Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) + | Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments -> Sc_rollup_refutation_punishments + | Burned -> Burned in return (ctxt, sink) - | #container as container -> ( + | Sink_container container -> ( match container with - | `Contract dest -> + | Contract dest -> Contract_storage.credit_only_call_from_token ctxt dest amount >|=? fun ctxt -> (ctxt, Contract dest) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.increase_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Contract_storage.increase_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate as dest -> + | Frozen_deposits delegate as dest -> allocated ctxt dest >>=? fun (ctxt, allocated) -> (if not allocated then Frozen_deposits_storage.init ctxt delegate else return ctxt) @@ -145,10 +147,10 @@ let credit ctxt dest amount origin = delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.credit_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.credit_bond_only_call_from_token ctxt contract @@ -157,53 +159,53 @@ let credit ctxt dest amount origin = >>=? fun ctxt -> return (ctxt, Frozen_bonds (contract, bond_id)))) >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin)) -let spend ctxt src amount origin = +let spend ctxt (src : source) amount origin = let open Receipt_repr in (match src with - | #infinite_source as infinite_source -> + | Source_infinite infinite_source -> let src = match infinite_source with - | `Bootstrap -> Bootstrap - | `Invoice -> Invoice - | `Initial_commitments -> Initial_commitments - | `Minted -> Minted - | `Liquidity_baking_subsidies -> Liquidity_baking_subsidies - | `Revelation_rewards -> Nonce_revelation_rewards - | `Double_signing_evidence_rewards -> Double_signing_evidence_rewards - | `Endorsing_rewards -> Endorsing_rewards - | `Baking_rewards -> Baking_rewards - | `Baking_bonuses -> Baking_bonuses - | `Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards + | Bootstrap -> Bootstrap + | Invoice -> Invoice + | Initial_commitments -> Initial_commitments + | Minted -> Minted + | Liquidity_baking_subsidies -> Liquidity_baking_subsidies + | Revelation_rewards -> Nonce_revelation_rewards + | Double_signing_evidence_rewards -> Double_signing_evidence_rewards + | Endorsing_rewards -> Endorsing_rewards + | Baking_rewards -> Baking_rewards + | Baking_bonuses -> Baking_bonuses + | Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards in return (ctxt, src) - | #container as container -> ( + | Source_container container -> ( match container with - | `Contract src -> + | Contract src -> Contract_storage.spend_only_call_from_token ctxt src amount >|=? fun ctxt -> (ctxt, Contract src) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.decrease_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.Implicit delegate in Contract_storage.decrease_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> Frozen_deposits_storage.spend_only_call_from_token ctxt delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.spend_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.spend_bond_only_call_from_token ctxt contract @@ -236,9 +238,10 @@ let transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest = List.fold_left_es (fun ctxt (source, _amount) -> match source with - | `Contract contract | `Frozen_bonds (contract, _) -> + | Source_container (Contract contract) + | Source_container (Frozen_bonds (contract, _)) -> Contract_storage.ensure_deallocated_if_empty ctxt contract - | #source -> return ctxt) + | _ -> return ctxt) ctxt sources >|=? fun ctxt -> diff --git a/src/proto_014_PtKathma/lib_protocol/token.mli b/src/proto_014_PtKathma/lib_protocol/token.mli index e7ff1c45c6b57..d6e72933ab8c1 100644 --- a/src/proto_014_PtKathma/lib_protocol/token.mli +++ b/src/proto_014_PtKathma/lib_protocol/token.mli @@ -43,43 +43,45 @@ stake. *) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t (** [infinite_source] defines types of tokens provides which are considered to be ** of infinite capacity. *) type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards (** [source] is the type of token providers. Token providers that are not containers are considered to have infinite capacity. *) -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Sc_rollup_refutation_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Tx_rollup_rejection_punishments + | Sc_rollup_refutation_punishments + | Burned (** [sink] is the type of token receivers. Token receivers that are not containers are considered to have infinite capacity. *) -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container (** [allocated ctxt container] returns a new context because of possible access to carbonated data, and a boolean that is [true] when @@ -110,8 +112,8 @@ val balance : val transfer_n : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - ([< source] * Tez_repr.t) list -> - [< sink] -> + (source * Tez_repr.t) list -> + sink -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t (** [transfer ?origin ctxt src dest amount] transfers [amount] Tez from source @@ -138,7 +140,7 @@ val transfer_n : val transfer : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - [< source] -> - [< sink] -> + source -> + sink -> Tez_repr.t -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.ml index 6de7e88e16950..3d8da9c0aaed5 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.ml @@ -94,7 +94,13 @@ type 'a template = { inbox_merkle_root : Tx_rollup_inbox_repr.Merkle.root; } -let map_template f x = {x with messages = f x.messages} +let map_template f x = + { + level = x.level; + messages = f x.messages; + predecessor = x.predecessor; + inbox_merkle_root = x.inbox_merkle_root; + } let pp_template : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a template -> unit diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.mli b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.mli index 8a396f24d3986..277059cb20e75 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.mli +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_repr.mli @@ -33,7 +33,7 @@ module Hash : sig include S.HASH end -module Merkle_hash : S.HASH +module Merkle_hash : S.HASH [@@coq_plain_module] module Merkle : Merkle_list.T diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.ml index 6d6d94eb93051..4dd4b82529170 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.ml @@ -50,10 +50,14 @@ open Tx_rollup_errors_repr *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + let check_message_result ctxt {messages; _} result ~path ~index = (match result with - | `Hash hash -> ok (ctxt, hash) - | `Result result -> Tx_rollup_hash_builder.message_result ctxt result) + | Hash hash -> ok (ctxt, hash) + | Result result -> Tx_rollup_hash_builder.message_result ctxt result) >>? fun (ctxt, computed) -> Tx_rollup_gas.consume_check_path_commitment_cost ctxt >>? fun ctxt -> let cond = @@ -71,11 +75,13 @@ let check_message_result ctxt {messages; _} result ~path ~index = cond Tx_rollup_errors_repr.( Wrong_rejection_hash - {provided = computed; expected = `Valid_path (messages.root, index)}) + {provided = computed; expected = Valid_path (messages.root, index)}) >>? fun () -> ok ctxt -let adjust_commitments_count ctxt tx_rollup pkh ~(dir : [`Incr | `Decr]) = - let delta = match dir with `Incr -> 1 | `Decr -> -1 in +type direction = Incr | Decr + +let adjust_commitments_count ctxt tx_rollup pkh ~(dir : direction) = + let delta = match dir with Incr -> 1 | Decr -> -1 in Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) pkh >>=? fun (ctxt, commitment) -> let count = @@ -249,7 +255,7 @@ let add_commitment ctxt tx_rollup state pkh commitment = commitment.level commitment_hash >>?= fun state -> - adjust_commitments_count ctxt tx_rollup pkh ~dir:`Incr >>=? fun ctxt -> + adjust_commitments_count ctxt tx_rollup pkh ~dir:Incr >>=? fun ctxt -> return (ctxt, state, to_slash) let pending_bonded_commitments : @@ -319,7 +325,7 @@ let remove_commitment ctxt rollup state = fail (Internal_error "Missing finalized_at field")) >>=? fun () -> (* Decrement the bond count of the committer *) - adjust_commitments_count ctxt rollup commitment.committer ~dir:`Decr + adjust_commitments_count ctxt rollup commitment.committer ~dir:Decr >>=? fun ctxt -> (* We remove the commitment *) Storage.Tx_rollup.Commitment.remove (ctxt, rollup) tail @@ -347,7 +353,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state check_message_result ctxt commitment - (`Hash disputed_result) + (Hash disputed_result) ~path:disputed_result_path ~index:disputed_position >>?= fun ctxt -> @@ -359,7 +365,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state let expected = Tx_rollup_message_result_hash_repr.init in fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) - (Wrong_rejection_hash {provided = agreed; expected = `Hash expected}) + (Wrong_rejection_hash {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | Some pred_level -> ( Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) pred_level @@ -372,7 +378,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) (Wrong_rejection_hash - {provided = agreed; expected = `Hash expected}) + {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | None -> ( match Tx_rollup_state_repr.last_removed_commitment_hashes state with @@ -380,14 +386,14 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = last_hash) (Wrong_rejection_hash - {provided = agreed; expected = `Hash last_hash}) + {provided = agreed; expected = Hash last_hash}) >>=? fun () -> return ctxt | None -> fail (Internal_error "Missing commitment predecessor"))) else check_message_result ctxt commitment - (`Result agreed_result) + (Result agreed_result) ~path:agreed_result_path ~index:(disputed_position - 1) >>?= fun ctxt -> return ctxt diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.mli b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.mli index 41af2357a0128..530b827607550 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.mli +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_commitment_storage.mli @@ -28,11 +28,14 @@ (** This module introduces various functions to manipulate the storage related to commitments for transaction rollups. *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : Raw_context.t -> Tx_rollup_commitment_repr.Compact.t -> - [ `Hash of Tx_rollup_message_result_hash_repr.t - | `Result of Tx_rollup_message_result_repr.t ] -> + hash_or_result -> path:Tx_rollup_commitment_repr.Merkle.path -> index:int -> Raw_context.t tzresult diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_errors_repr.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_errors_repr.ml index a79f10792ef97..bd9596b5f0cb6 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_errors_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_errors_repr.ml @@ -25,6 +25,12 @@ (* *) (*****************************************************************************) +type error_or_commitment = Inbox | Commitment + +type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment_repr.Merkle.h * int + | Hash of Tx_rollup_message_result_hash_repr.t + type error += | Tx_rollup_already_exists of Tx_rollup_repr.t | Tx_rollup_does_not_exist of Tx_rollup_repr.t @@ -61,7 +67,7 @@ type error += length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -82,9 +88,7 @@ type error += } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash_repr.t; - expected : - [ `Valid_path of Tx_rollup_commitment_repr.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash_repr.t ]; + expected : valid_path_or_hash; } | Ticket_payload_size_limit_exceeded of {payload_size : int; limit : int} | Wrong_deposit_parameters @@ -411,14 +415,14 @@ let () = (Tag 0) ~title:"Inbox" (constant "inbox") - (function `Inbox -> Some () | _ -> None) - (fun () -> `Inbox); + (function Inbox -> Some () | _ -> None) + (fun () -> Inbox); case (Tag 1) ~title:"Commitment" (constant "commitment") - (function `Commitment -> Some () | _ -> None) - (fun () -> `Commitment); + (function Commitment -> Some () | _ -> None) + (fun () -> Commitment); ])) (req "provided" int31) (req "limit" int31)) @@ -593,16 +597,16 @@ let () = (Tag 0) ~title:"hash" Tx_rollup_message_result_hash_repr.encoding - (function `Hash h -> Some h | _ -> None) - (fun h -> `Hash h); + (function Hash h -> Some h | _ -> None) + (fun h -> Hash h); case (Tag 1) ~title:"valid_path" (obj2 (req "root" Tx_rollup_commitment_repr.Merkle_hash.encoding) (req "index" int31)) - (function `Valid_path (h, i) -> Some (h, i) | _ -> None) - (fun (h, i) -> `Valid_path (h, i)); + (function Valid_path (h, i) -> Some (h, i) | _ -> None) + (fun (h, i) -> Valid_path (h, i)); ]))) (function | Wrong_rejection_hash {provided; expected} -> Some (provided, expected) diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_gas.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_gas.ml index 6ae5cb451f107..bfa38362a572a 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_gas.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_gas.ml @@ -53,7 +53,7 @@ let check_path_cost element_size path_depth = hash_cost element_size >>? fun element_hash_cost -> (* At each step of the way, we hash 2 hashes together *) hash_cost 64 >>? fun hash_cost -> - let rec acc_hash_cost acc i = + let[@coq_struct "i_value"] rec acc_hash_cost acc i = if Compare.Int.(i <= 0) then acc else acc_hash_cost (hash_cost + acc) (i - 1) in diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.ml index cf2c1dd815a70..5ff39b2de8c9e 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.ml @@ -317,12 +317,81 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module Make (Context : CONTEXT) = struct +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 + + type ctxt_type + + type 'a m + + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m + + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end + +module type S = sig + type ctxt_type + + type 'a m + + (** The operations are versioned (see {!Tx_rollup_l2_batch}), + so their interpretations are. *) + + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m + + (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 + address in [ctxt]. + + This function can fail if the [deposit.amount] is not strictly-positive. + + If the [deposit] causes an error, then a withdrawal returning + the funds to the deposit's sender is returned. + *) + val apply_deposit : + ctxt_type -> + Tx_rollup_message.deposit -> + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + + (** [apply_message ctxt parameters message] interprets the [message] in the + [ctxt]. + + That is, + + {ul {li Deposit tickets if the message is a deposit. } + {li Decodes the batch and interprets it for the + correct batch version. }} + + The function can fail with {!Invalid_batch_encoding} if it's not able + to decode the batch. + + The function can also return errors from subsequent functions, + see {!apply_deposit} and batch interpretations for various versions. + + The list of withdrawals in the message result followed the ordering + of the contents in the message. + *) + val apply_message : + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m +end + +module Make (Context : CONTEXT) : + S with type ctxt_type = Context.t and type 'a m := 'a Context.m = struct open Context open Syntax open Message_result - type ctxt = Context.t + type ctxt_type = Context.t (** {3. Indexes. } *) @@ -336,8 +405,8 @@ module Make (Context : CONTEXT) = struct | Right v -> ( let+ ctxt, created, idx = get_or_associate_index ctxt v in match created with - | `Existed -> (ctxt, indexes, idx) - | `Created -> (ctxt, add_index indexes (v, idx), idx)) + | Existed -> (ctxt, indexes, idx) + | Created -> (ctxt, add_index indexes (v, idx), idx)) | Left i -> return (ctxt, indexes, i) let address_index ctxt indexes indexable = @@ -372,7 +441,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata ctxt idx] returns the metadata associated to [idx] in [ctxt]. It must have an associated metadata in the context, otherwise, something went wrong in {!check_signature}. *) - let get_metadata : ctxt -> address_index -> metadata m = + let get_metadata : ctxt_type -> address_index -> metadata m = fun ctxt idx -> let open Address_metadata in let* metadata = get ctxt idx in @@ -382,7 +451,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata_signer] gets the metadata for a signer using {!get_metadata}. It transforms a signer index to an address one. *) - let get_metadata_signer : ctxt -> Signer_indexable.index -> metadata m = + let get_metadata_signer : ctxt_type -> Signer_indexable.index -> metadata m = fun ctxt signer_idx -> get_metadata ctxt (address_of_signer_index signer_idx) (** [transfers ctxt source_idx destination_idx tidx amount] transfers [amount] @@ -402,7 +471,8 @@ module Make (Context : CONTEXT) = struct we only handle the creation part (i.e. in the layer2) in this module. *) let deposit ctxt aidx tidx amount = Ticket_ledger.credit ctxt tidx aidx amount - module Batch_V1 = struct + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m = struct open Tx_rollup_l2_batch.V1 (** [operation_with_signer_index ctxt indexes op] takes an operation @@ -419,10 +489,10 @@ module Make (Context : CONTEXT) = struct {b Note:} If the context already contains all the required information, we only read from it. *) let operation_with_signer_index : - ctxt -> + ctxt_type -> indexes -> ('signer, 'content) operation -> - (ctxt + (ctxt_type * indexes * (Indexable.index_only, 'content) operation * Bls_signature.pk) @@ -445,7 +515,7 @@ module Make (Context : CONTEXT) = struct (* If the address is created, we add it to [indexes]. *) match created with - | `Existed -> + | Existed -> (* If the public key existed in the context, it should not be added in [indexes]. However, the metadata might not have been initialized for the public key. Especially during @@ -463,7 +533,7 @@ module Make (Context : CONTEXT) = struct Address_metadata.init_with_public_key ctxt idx signer_pk in return (ctxt, indexes, signer_pk, idx) - | `Created -> + | Created -> (* If the index is created, we need to add to indexes and initialize the metadata. *) let indexes = @@ -542,9 +612,9 @@ module Make (Context : CONTEXT) = struct return (ctxt, indexes, transmitted, List.rev rev_ops) let check_signature : - ctxt -> + ctxt_type -> ('signer, 'content) t -> - (ctxt * indexes * (Indexable.index_only, 'content) t) m = + (ctxt_type * indexes * (Indexable.index_only, 'content) t) m = fun ctxt ({contents = transactions; aggregated_signature} as batch) -> let* ctxt, indexes, transmitted, rev_new_transactions = list_fold_left_m @@ -578,11 +648,11 @@ module Make (Context : CONTEXT) = struct {li The ticket exchanged index.}} *) let apply_operation_content : - ctxt -> + ctxt_type -> indexes -> Signer_indexable.index -> 'content operation_content -> - (ctxt * indexes * Tx_rollup_withdraw.t option) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t option) m = fun ctxt indexes source_idx op_content -> match op_content with | Withdraw {destination = claimer; ticket_hash; qty = amount} -> @@ -614,7 +684,8 @@ module Make (Context : CONTEXT) = struct (** [check_counter ctxt signer counter] asserts that the provided [counter] is the successor of the one associated to the [signer] in the [ctxt]. *) let check_counter : - ctxt -> Indexable.index_only Signer_indexable.t -> int64 -> unit m = + ctxt_type -> Indexable.index_only Signer_indexable.t -> int64 -> unit m + = fun ctxt signer counter -> let* metadata = get_metadata_signer ctxt signer in fail_unless @@ -629,10 +700,10 @@ module Make (Context : CONTEXT) = struct (** [apply_operation ctxt indexes op] checks the counter validity for the [op.signer] with {!check_counter}, and then calls {!apply_operation_content} for each content in [op]. *) let apply_operation : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) operation -> - (ctxt * indexes * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t list) m = fun ctxt indexes {signer; counter; contents} -> (* Before applying any operation, we check the counter *) let* () = check_counter ctxt signer counter in @@ -655,12 +726,14 @@ module Make (Context : CONTEXT) = struct is left untouched. *) let apply_transaction : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) transaction -> - (ctxt * indexes * transaction_result * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * transaction_result * Tx_rollup_withdraw.t list) m + = fun initial_ctxt initial_indexes transaction -> - let rec fold (ctxt, prev_indexes, withdrawals) index ops = + let rec fold params index ops = + let ctxt, prev_indexes, withdrawals = params in match ops with | [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals) | op :: rst -> @@ -688,7 +761,8 @@ module Make (Context : CONTEXT) = struct failed because of a [Counter_mismatch] the counters are left untouched. *) - let update_counters ctxt status transaction = + let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters + ctxt status transaction = match status with | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt | Transaction_failure _ | Transaction_success -> @@ -700,10 +774,10 @@ module Make (Context : CONTEXT) = struct transaction let apply_batch : - ctxt -> + ctxt_type -> parameters -> (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = fun ctxt parameters batch -> let* ctxt, indexes, batch = check_signature ctxt batch in let {contents; _} = batch in @@ -736,9 +810,9 @@ module Make (Context : CONTEXT) = struct end let apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * deposit_result * Tx_rollup_withdraw.t option) m = + (ctxt_type * deposit_result * Tx_rollup_withdraw.t option) m = fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} -> let apply_deposit () = let* ctxt, indexes, aidx = @@ -763,7 +837,10 @@ module Make (Context : CONTEXT) = struct return (initial_ctxt, Deposit_failure reason, Some withdrawal)) let apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m = + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m = fun ctxt parameters msg -> let open Tx_rollup_message in match msg with diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.mli index 44619b09fe58b..33e8af74ad1f3 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.mli +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_apply.mli @@ -122,73 +122,80 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module Make (Context : CONTEXT) : sig - open Context +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 - type ctxt = t + type ctxt_type + + type 'a m + + (** [apply_batch ctxt parameters batch] interprets the batch + {!Tx_rollup_l2_batch.V1.t}. + + By construction, a failing transaction will not affect the [ctxt] + and other transactions will still be interpreted. + That is, this function can only fail because of internals errors. + Otherwise, the errors that caused the transactions to fail can be + observed in the result (see {!Message_result.Batch_V1.t}). + + The counters are incremented when the operation is part of a transaction + that is correctly signed and whose every operations have the expected + counter. In particular, the result of the application is not important + (i.e. the counters are updated even if the transaction failed). + + In addition, the list of withdrawals resulting from each + layer2-to-layer1 transfer message in the batch is returned. + *) + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m + + (** [check_signature ctxt batch] asserts that [batch] is correctly signed. + + We recall that [batch] may contain indexes, that is integers which + replace larger values. The [signer] field of the + {!Tx_rollup_l2_batch.operation} type is concerned. This field is either + the public key to be used to check the signature, or an index. + In case of the public key, [check_signature] will check whether or not + the related {!Tx_rollup_l2_address.t} has already an index assigned, + and allocate one if not. + + Overall, [check_signature] returns the revised context, the list of + newly allocated indexes, and an updated version of the batches where + all [signer] field have been replaced by valid indexes. + + {b Note:} What a user is expected to sign is the version of the + operation it sends to the network. This is potentially unsafe, + because it means the user signs indexes, not addresses nor + ticket hashes. This poses two threats: Tezos reorganization, + and malicious provider of indexes. A Tezos reorganization may + imply that an index allocated to one address in a given branch + is allocated to another address in another branch. We deal with + this issue by making the rollup node aware of the Tezos level at + each time an index is allocated. This allows to implement a RPC that + can safely tell a client to use either the full value or the index, + thanks to Tenderbake finality. To prevent the rollup node to lie, + we will make the rollup node provide Merkle proofs that allows the + client to verify that the index is correct. + *) + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end + +module type S = sig + type ctxt_type + + type 'a m (** The operations are versioned (see {!Tx_rollup_l2_batch}), so their interpretations are. *) - module Batch_V1 : sig - open Tx_rollup_l2_batch.V1 - - (** [apply_batch ctxt parameters batch] interprets the batch - {!Tx_rollup_l2_batch.V1.t}. - - By construction, a failing transaction will not affect the [ctxt] - and other transactions will still be interpreted. - That is, this function can only fail because of internals errors. - Otherwise, the errors that caused the transactions to fail can be - observed in the result (see {!Message_result.Batch_V1.t}). - - The counters are incremented when the operation is part of a transaction - that is correctly signed and whose every operations have the expected - counter. In particular, the result of the application is not important - (i.e. the counters are updated even if the transaction failed). - - In addition, the list of withdrawals resulting from each - layer2-to-layer1 transfer message in the batch is returned. - *) - val apply_batch : - ctxt -> - parameters -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m - - (** [check_signature ctxt batch] asserts that [batch] is correctly signed. - - We recall that [batch] may contain indexes, that is integers which - replace larger values. The [signer] field of the - {!Tx_rollup_l2_batch.operation} type is concerned. This field is either - the public key to be used to check the signature, or an index. - In case of the public key, [check_signature] will check whether or not - the related {!Tx_rollup_l2_address.t} has already an index assigned, - and allocate one if not. - - Overall, [check_signature] returns the revised context, the list of - newly allocated indexes, and an updated version of the batches where - all [signer] field have been replaced by valid indexes. - - {b Note:} What a user is expected to sign is the version of the - operation it sends to the network. This is potentially unsafe, - because it means the user signs indexes, not addresses nor - ticket hashes. This poses two threats: Tezos reorganization, - and malicious provider of indexes. A Tezos reorganization may - imply that an index allocated to one address in a given branch - is allocated to another address in another branch. We deal with - this issue by making the rollup node aware of the Tezos level at - each time an index is allocated. This allows to implement a RPC that - can safely tell a client to use either the full value or the index, - thanks to Tenderbake finality. To prevent the rollup node to lie, - we will make the rollup node provide Merkle proofs that allows the - client to verify that the index is correct. - *) - val check_signature : - ctxt -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m - end + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 address in [ctxt]. @@ -199,9 +206,9 @@ module Make (Context : CONTEXT) : sig the funds to the deposit's sender is returned. *) val apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m (** [apply_message ctxt parameters message] interprets the [message] in the [ctxt]. @@ -222,5 +229,11 @@ module Make (Context : CONTEXT) : sig of the contents in the message. *) val apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m end + +module Make (Context : CONTEXT) : + S with type ctxt_type = Context.t and type 'a m := 'a Context.m diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.ml index 37379c6fd0e97..9c4232d3aec78 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.ml @@ -144,7 +144,7 @@ module V1 = struct let operation_content_encoding = Data_encoding.Compact.make ~tag_size compact_operation_content - let compact_operation encoding_signer = + let compact_operation_raw encoding_signer = Data_encoding.Compact.( conv (fun {signer; counter; contents} -> (signer, counter, contents)) @@ -154,30 +154,32 @@ module V1 = struct (req "counter" int64) (req "contents" @@ list ~bits:4 operation_content_encoding)) - let operation_encoding encoding_signer = - Data_encoding.Compact.(make ~tag_size (compact_operation encoding_signer)) + let operation_encoding_raw encoding_signer = + Data_encoding.Compact.( + make ~tag_size (compact_operation_raw encoding_signer)) - let compact_transaction encoding_signer = - Data_encoding.Compact.list ~bits:8 (operation_encoding encoding_signer) + let compact_transaction_raw encoding_signer = + Data_encoding.Compact.list ~bits:8 (operation_encoding_raw encoding_signer) - let transaction_encoding : + let transaction_encoding_raw : 'a -> ('b, Indexable.unknown) transaction Data_encoding.t = fun encoding_signer -> - Data_encoding.Compact.(make ~tag_size (compact_transaction encoding_signer)) + Data_encoding.Compact.( + make ~tag_size (compact_transaction_raw encoding_signer)) let compact_signer_index = Data_encoding.Compact.(conv Indexable.to_int32 Indexable.index_exn int32) let compact_signer_either = Signer_indexable.compact - let compact_operation = compact_operation compact_signer_either + let compact_operation = compact_operation_raw compact_signer_either let compact_transaction_signer_index = - compact_transaction compact_signer_index + compact_transaction_raw compact_signer_index - let compact_transaction = compact_transaction compact_signer_either + let compact_transaction = compact_transaction_raw compact_signer_either - let transaction_encoding = transaction_encoding compact_signer_either + let transaction_encoding = transaction_encoding_raw compact_signer_either let compact ~bits : (Indexable.unknown, Indexable.unknown) t Data_encoding.Compact.t = diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.mli b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.mli index e59261c998aad..ef323fe52c745 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.mli +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_batch.mli @@ -77,21 +77,7 @@ type signer = (** A signer identified by a layer-2 address. Each such adress is in turn identified with a BLS public key. *) -module Signer_indexable : sig - type nonrec 'state t = ('state, signer) Indexable.t - - type nonrec index = signer Indexable.index - - type nonrec value = signer Indexable.value - - type either = signer Indexable.either - - val encoding : either Data_encoding.t - - val compare : either -> either -> int - - val pp : Format.formatter -> either -> unit -end +module Signer_indexable : Indexable.INDEXABLE with type v_t := signer (** {1 Layer-2 Batches Definitions} *) diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context.ml index 453e1588df777..8e9f1c5457633 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context.ml @@ -119,7 +119,7 @@ let packed_key_encoding : packed_key Data_encoding.t = underlying storage. *) let value_encoding : type a. a key -> a Data_encoding.t = let open Data_encoding in - function + function[@coq_match_gadt_with_result] | Address_metadata _ -> metadata_encoding | Address_count -> int32 | Address_index _ -> Tx_rollup_l2_address.Indexable.index_encoding @@ -175,7 +175,8 @@ struct type 'a m = 'a S.m - module Syntax = struct + module Syntax : Tx_rollup_l2_context_sig.SYNTAX with type 'a m := 'a m = + struct include S.Syntax let ( let*? ) res f = @@ -274,7 +275,12 @@ struct end end - module Address_index = struct + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Address_count in @@ -301,17 +307,22 @@ struct let open Syntax in let* index_opt = get ctxt addr in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ ctxt, idx = associate_index ctxt addr in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Address_count count end end - module Ticket_index = struct + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Ticket_count in @@ -338,17 +349,18 @@ struct let open Syntax in let* index_opt = get ctxt ticket in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ ctxt, idx = associate_index ctxt ticket in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Ticket_count count end end - module Ticket_ledger = struct + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m = + struct let get_opt ctxt tidx aidx = get ctxt (Ticket_ledger (tidx, aidx)) let get ctxt tidx aidx = diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context_sig.ml index ba8d16138f325..a706f3d14673d 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_context_sig.ml @@ -157,198 +157,137 @@ let () = (function Counter_overflow -> Some () | _ -> None) (fun () -> Counter_overflow) -(** This module type describes the API of the [Tx_rollup] context, - which is used to implement the semantics of the L2 operations. *) -module type CONTEXT = sig - (** The state of the [Tx_rollup] context. - - The context provides a type-safe, functional API to interact - with the state of a transaction rollup. The functions of this - module, manipulating and creating values of type [t] are called - “context operations” afterwards. *) - type t +type created_existed = Created | Existed - (** The monad used by the context. - - {b Note:} It is likely to be the monad of the underlying - storage. In the case of the proof verifier, as it is expected to - be run into the L1, the monad will also be used to perform gas - accounting. This is why all the functions of this module type - needs to be inside the monad [m]. *) +(** The necessary monadic operators the storage monad is required to + provide. *) +module type SYNTAX = sig type 'a m - (** The necessary monadic operators the storage monad is required to - provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - (** [let*?] is for binding the value from Result-only - expressions into the storage monad. *) - val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m + (** [let*?] is for binding the value from Result-only + expressions into the storage monad. *) + val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m - (** [fail err] shortcuts the current computation by raising an - error. + (** [fail err] shortcuts the current computation by raising an + error. - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) - val fail_unless : bool -> error -> unit m + (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) + val fail_unless : bool -> error -> unit m - (** [fail_when cond err] raises [err] iff [cond] is [true]. *) - val fail_when : bool -> error -> unit m - end - - (** [bls_aggregate_verify] allows to verify the aggregated signature - of a batch. *) - val bls_verify : (Bls_signature.pk * bytes) list -> signature -> bool m + (** [fail_when cond err] raises [err] iff [cond] is [true]. *) + val fail_when : bool -> error -> unit m +end - (** The metadata associated to an address. *) - module Address_metadata : sig - (** [get ctxt idx] returns the current metadata associated to the - address indexed by [idx]. *) - val get : t -> address_index -> metadata option m +module type ADDRESS_METADATA = sig + type t - (** [incr_counter ctxt idx] increments the counter of the - address indexed by [idx]. + type 'a m - This function can fail with [Counter_overflow] iff the counter - has reached the [Int64.max_int] limit. + (** [get ctxt idx] returns the current metadata associated to the + address indexed by [idx]. *) + val get : t -> address_index -> metadata option m - This function can fail with [Unknown_address_index] if [idx] - has not been associated with a layer-2 address already. *) - val incr_counter : t -> address_index -> t m + (** [incr_counter ctxt idx] increments the counter of the + address indexed by [idx]. - (** [init_with_public_key ctxt idx pk] initializes the metadata - associated to the address indexed by [idx]. + This function can fail with [Counter_overflow] iff the counter + has reached the [Int64.max_int] limit. - This can fails with [Metadata_already_initialized] if this - function has already been called with [idx]. *) - val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m + This function can fail with [Unknown_address_index] if [idx] + has not been associated with a layer-2 address already. *) + val incr_counter : t -> address_index -> t m - (**/**) + (** [init_with_public_key ctxt idx pk] initializes the metadata + associated to the address indexed by [idx]. - module Internal_for_tests : sig - val set : t -> address_index -> metadata -> t m - end - end + This can fails with [Metadata_already_initialized] if this + function has already been called with [idx]. *) + val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m - (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + (**/**) - Addresses are supposed to be associated to a {!address_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time an address is used in a layer2 - operation, we associate it to a address_index that should be use - in future layer2 operations. - *) - module Address_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in - the context. *) - val init_counter : t -> t m - - (** [get ctxt addr] returns the index associated to [addr], if - any. *) - val get : t -> Tx_rollup_l2_address.t -> address_index option m - - (** [get_or_associate_index ctxt addr] associates a fresh [address_index] - to [addr], and returns it. If the [addr] has already been associated to - an index, it returns it. - It also returns the information on whether the index was created or - already existed. - - This function can fail with [Too_many_l2_addresses] iff there - is no fresh index available. *) - val get_or_associate_index : - t -> - Tx_rollup_l2_address.t -> - (t * [`Created | `Existed] * address_index) m + module Internal_for_tests : sig + val set : t -> address_index -> metadata -> t m + end +end - (** [count ctxt] returns the number of addresses that have been - involved in the transaction rollup. *) - val count : t -> int32 m +module type INDEX = sig + type t - (**/**) + type 'a m - module Internal_for_tests : sig - (** [set ctxt count] sets the [count] in [ctxt]. It is used to test - the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end - end + type hash - (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + type index - Ticket hashes are supposed to be associated to a {!ticket_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time a ticket hash is used in a layer2 - operation, we associate it to a ticket_index that should be use - in future layer2 operations. - *) - module Ticket_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in + (** [init_counter ctxt] writes the default counter (i.e. [0L]) in the context. *) - val init_counter : t -> t m + val init_counter : t -> t m - (** [get ctxt ticket] returns the index associated to [ticket], if + (** [get ctxt hash] returns the index associated to [hash], if any. *) - val get : t -> Alpha_context.Ticket_hash.t -> ticket_index option m + val get : t -> hash -> index option m - (** [get_or_associate_index ctxt ticket] associates a fresh [ticket_index] - to [ticket], and returns it. If the [ticket] has already been associated + (** [get_or_associate_index ctxt hash] associates a fresh [index] + to [hash], and returns it. If the [hash] has already been associated to an index, it returns it. It also returns the information on whether the index was created or already existed. This function can fail with [Too_many_l2_tickets] iff there is no fresh index available. *) - val get_or_associate_index : - t -> - Alpha_context.Ticket_hash.t -> - (t * [`Created | `Existed] * ticket_index) m + val get_or_associate_index : t -> hash -> (t * created_existed * index) m - (** [count ctxt] returns the number of tickets that have been + (** [count ctxt] returns the number of tickets that have been involved in the transaction rollup. *) - val count : t -> int32 m + val count : t -> int32 m - (**/**) + (**/**) - module Internal_for_tests : sig - (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test + module Internal_for_tests : sig + (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end + val set_count : t -> int32 -> t m end +end - (** The ledger of the layer 2 where are registered the amount of a - given ticket a L2 [account] has in its possession. *) - module Ticket_ledger : sig - (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] +module type TICKET_LEDGER = sig + type t + + type 'a m + + (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] owns. {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. The function will return zero when the address has no such ticket. *) - val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m + val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m - (** [credit ctxt tidx aidx qty] updates the ledger to + (** [credit ctxt tidx aidx qty] updates the ledger to increase the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -362,9 +301,9 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - (** [spend ctxt tidx aidx qty] updates the ledger to + (** [spend ctxt tidx aidx qty] updates the ledger to decrease the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -374,11 +313,76 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - module Internal_for_tests : sig - val get_opt : - t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m - end + module Internal_for_tests : sig + val get_opt : + t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m end end + +(** This module type describes the API of the [Tx_rollup] context, + which is used to implement the semantics of the L2 operations. *) +module type CONTEXT = sig + (** The state of the [Tx_rollup] context. + + The context provides a type-safe, functional API to interact + with the state of a transaction rollup. The functions of this + module, manipulating and creating values of type [t] are called + “context operations” afterwards. *) + type t + + (** The monad used by the context. + + {b Note:} It is likely to be the monad of the underlying + storage. In the case of the proof verifier, as it is expected to + be run into the L1, the monad will also be used to perform gas + accounting. This is why all the functions of this module type + needs to be inside the monad [m]. *) + type 'a m + + module Syntax : SYNTAX with type 'a m := 'a m + + (** [bls_aggregate_verify] allows to verify the aggregated signature + of a batch. *) + val bls_verify : + (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m + + (** The metadata associated to an address. *) + module Address_metadata : + ADDRESS_METADATA with type t := t and type 'a m := 'a m + + (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + + Addresses are supposed to be associated to a {!address_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time an address is used in a layer2 + operation, we associate it to a address_index that should be use + in future layer2 operations. + *) + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index + + (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + + Ticket hashes are supposed to be associated to a {!ticket_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time a ticket hash is used in a layer2 + operation, we associate it to a ticket_index that should be use + in future layer2 operations. + *) + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index + + (** The ledger of the layer 2 where are registered the amount of a + given ticket a L2 [account] has in its possession. *) + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m +end diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_storage_sig.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_storage_sig.ml index 4a81f9cd41808..2b62542033cea 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_storage_sig.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_storage_sig.ml @@ -25,6 +25,39 @@ (* *) (*****************************************************************************) +(** The necessary monadic operators the monad of the storage backend + is required to provide. *) +module type SYNTAX = sig + type t + + type 'a m + + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + + (** [fail err] shortcuts the current computation by raising an + error. + + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m + + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m + + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m +end + (** This module type is the minimal API a storage backend has to implement to be compatible with the [Tx_rollup] layer-2 implementation. @@ -44,34 +77,7 @@ module type STORAGE = sig (** The monad of the storage backend. *) type 'a m - (** The necessary monadic operators the monad of the storage backend - is required to provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - - (** [fail err] shortcuts the current computation by raising an - error. - - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m - - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m - - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - end + module Syntax : SYNTAX with type t := t and type 'a m := 'a m (** [get storage key] returns the value stored in [storage] for [key], if it exists. Returns [None] if it does not. *) diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_verifier.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_verifier.ml index 6b74152df4d8e..b25cc153c476d 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_verifier.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_l2_verifier.ml @@ -75,17 +75,18 @@ module Verifier_storage : type 'a m = ('a, error) result Lwt.t module Syntax = struct - let ( let* ) = ( >>=? ) + let ( let* ) : 'a m -> ('a -> 'b m) -> 'b m = ( >>=? ) - let ( let+ ) = ( >|=? ) + let ( let+ ) : 'a m -> ('a -> 'b) -> 'b m = ( >|=? ) - let return = return + let return : 'a -> 'a m = return - let fail e = Lwt.return (Error e) + let fail (e : error) : 'a m = Lwt.return (Error e) let catch (m : 'a m) k h = m >>= function Ok x -> k x | Error e -> h e - let list_fold_left_m = List.fold_left_es + let list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m = + List.fold_left_es end let path k = [Bytes.to_string k] @@ -124,8 +125,8 @@ let verify_l2_proof proof parameters message = Note that if the proof is incorrect this function fails and the commit can not be rejected. *) -let compute_proof_after_hash ~max_proof_size ctxt parameters agreed proof - message = +let[@coq_axiom_with_reason "nested pattern with polymorphic variant"] compute_proof_after_hash + ~max_proof_size ctxt parameters agreed proof message = let proof_length = Data_encoding.Binary.length Tx_rollup_l2_proof.encoding proof in diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_message_repr.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_message_repr.ml index a393b22676f9b..528e762b54bcb 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_message_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_message_repr.ml @@ -71,7 +71,7 @@ let encoding = (fun deposit -> Deposit deposit); ] -let pp fmt = +let[@coq_axiom_with_reason "unresolved implicit arguments"] pp fmt = let open Format in function | Batch str -> diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_parameters.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_parameters.ml index 7c93e0a7f75e9..3c7a6be8e9cbf 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_parameters.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_parameters.ml @@ -35,8 +35,10 @@ let get_deposit_parameters : (a, comparable) Script_typed_ir.ty -> a -> deposit_parameters tzresult = fun ty contents -> let open Script_typed_ir in - match (ty, contents) with + match[@coq_match_gadt] (ty, contents) with | ( Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _), - (ticket, l2_destination) ) -> + (contents : + _ Script_typed_ir.ticket * Script_typed_ir.tx_rollup_l2_address) ) -> + let ticket, l2_destination = contents in ok {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination} | _ -> error Alpha_context.Tx_rollup_errors.Wrong_deposit_parameters diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_state_repr.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_state_repr.ml index 104b9f1e00d1d..ba4e6b1ece854 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_state_repr.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_state_repr.ml @@ -430,7 +430,7 @@ let update_burn_per_byte_helper : be the maximum amount. *) | Error _ -> {state with burn_per_byte = Tez_repr.max_mutez; inbox_ema} -let rec update_burn_per_byte : +let[@coq_struct "elapsed"] rec update_burn_per_byte : t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t = fun state ~elapsed ~factor ~final_size ~hard_limit -> (* factor is expected to be a low number ~ 100 *) diff --git a/src/proto_014_PtKathma/lib_protocol/tx_rollup_ticket.ml b/src/proto_014_PtKathma/lib_protocol/tx_rollup_ticket.ml index d4549894b9f79..ddece37a0b1ad 100644 --- a/src/proto_014_PtKathma/lib_protocol/tx_rollup_ticket.ml +++ b/src/proto_014_PtKathma/lib_protocol/tx_rollup_ticket.ml @@ -31,8 +31,8 @@ let parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt = Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data [@coq_type_annotation]) ctxt contents_type (Micheline.root contents) @@ -46,8 +46,8 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data [@coq_type_annotation]) ctxt contents_type (Micheline.root contents) diff --git a/src/proto_014_PtKathma/lib_protocol/validate_operation.ml b/src/proto_014_PtKathma/lib_protocol/validate_operation.ml index 0f40584fb8f9e..f6a08533e472a 100644 --- a/src/proto_014_PtKathma/lib_protocol/validate_operation.ml +++ b/src/proto_014_PtKathma/lib_protocol/validate_operation.ml @@ -444,7 +444,7 @@ module Manager = struct in let* () = Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:max_messages_per_inbox in @@ -482,18 +482,18 @@ module Manager = struct in let* () = Tx_rollup_errors.check_path_depth - `Inbox + Inbox (Tx_rollup_inbox.Merkle.path_depth message_path) ~count_limit:max_messages_per_inbox in let* () = Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:max_messages_per_inbox in Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth previous_message_result_path) ~count_limit:max_messages_per_inbox -- GitLab