From bb7a7b988d8cdbea6018904308ba3e5699bfe049 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, K and Alpha for coq-of-ocaml --- src/lib_context/sigs/context.ml | 4 + src/lib_crypto/blake2B.ml | 15 +- src/lib_crypto/blake2B.mli | 16 +- .../environment_V3.ml | 4 +- .../environment_V4.ml | 4 +- .../environment_V5.ml | 4 +- .../environment_V6.ml | 16 +- .../environment_V7.ml | 12 + .../environment_V8.ml | 16 + .../environment_context_intf.ml | 2 + .../environment_protocol_T.ml | 4 +- .../environment_protocol_T_V7.ml | 4 +- .../environment_protocol_T_test.ml | 4 +- src/lib_protocol_environment/sigs/v4.ml | 6 +- .../sigs/v4/context.mli | 6 +- src/lib_protocol_environment/sigs/v5.in.ml | 115 +- src/lib_protocol_environment/sigs/v5.ml | 207 +-- .../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 +- src/lib_protocol_environment/sigs/v6.in.ml | 121 +- src/lib_protocol_environment/sigs/v6.ml | 227 +-- .../sigs/v6/bounded.mli | 2 +- .../sigs/v6/compare.mli | 1 + .../sigs/v6/wasm_2_0_0.mli | 17 +- src/lib_protocol_environment/sigs/v7.in.ml | 125 +- src/lib_protocol_environment/sigs/v7.ml | 235 +-- .../sigs/v7/compare.mli | 1 + .../sigs/v7/updater.mli | 4 +- .../sigs/v7/wasm_2_0_0.mli | 17 +- src/lib_protocol_environment/sigs/v8.ml | 25 +- .../sigs/v8/updater.mli | 4 +- .../sigs/v8/wasm_2_0_0.mli | 21 +- .../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 | 1024 +++++++----- .../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 +- .../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 - .../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 | 18 +- .../lib_protocol/alpha_context.mli | 220 +-- src/proto_014_PtKathma/lib_protocol/apply.ml | 131 +- .../lib_protocol/apply_internal_results.ml | 38 +- .../lib_protocol/apply_operation_result.ml | 3 +- .../lib_protocol/apply_operation_result.mli | 3 +- .../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/contract_services.ml | 17 +- .../lib_protocol/contract_storage.ml | 26 +- .../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 | 40 +- .../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 | 8 +- .../lib_protocol/lazy_storage_diff.ml | 36 +- .../lib_protocol/lazy_storage_kind.ml | 49 +- .../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 | 39 +- .../lib_protocol/operation_repr.ml | 251 +-- .../lib_protocol/operation_repr.mli | 23 +- .../lib_protocol/period_repr.ml | 4 +- .../lib_protocol/raw_context.ml | 76 +- .../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 | 28 +- .../lib_protocol/sc_rollup_game_repr.ml | 10 +- .../lib_protocol/sc_rollup_inbox_repr.ml | 44 +- .../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 | 20 +- .../sc_rollup_refutation_storage.ml | 10 +- .../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 | 38 +- .../lib_protocol/sc_rollups.ml | 40 +- .../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 | 868 ++++++----- .../lib_protocol/script_interpreter_defs.ml | 452 +++--- .../script_interpreter_logging.ml | 120 +- .../script_interpreter_logging.mli | 1 + .../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 | 124 +- .../lib_protocol/script_typed_ir.mli | 15 +- .../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 | 221 ++- .../lib_protocol/storage.mli | 2 +- .../lib_protocol/storage_description.ml | 135 +- .../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 | 71 +- .../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 | 74 +- .../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 | 22 +- .../lib_protocol/voting_services.ml | 3 - .../lib_protocol/mempool_validation.ml | 13 +- .../lib_protocol/mempool_validation.mli | 4 +- .../script_interpreter_logging.ml | 158 +- .../script_interpreter_logging.mli | 1 + .../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 | 421 +++-- .../test/unit/test_tx_rollup_l2.ml | 11 +- .../lib_protocol/tx_rollup_ticket.ml | 8 +- .../lib_client/client_proto_context.ml | 2 +- .../lib_client/client_proto_rollups.ml | 4 +- .../client_baking_denunciation.ml | 6 +- .../lib_injector/injector_functor.ml | 2 +- src/proto_alpha/lib_plugin/RPC.ml | 17 +- src/proto_alpha/lib_protocol/alpha_context.ml | 16 +- .../lib_protocol/alpha_context.mli | 229 +-- src/proto_alpha/lib_protocol/amendment.ml | 11 +- src/proto_alpha/lib_protocol/apply.ml | 148 +- .../lib_protocol/apply_internal_results.ml | 77 +- .../lib_protocol/apply_operation_result.ml | 2 +- .../lib_protocol/apply_operation_result.mli | 2 +- src/proto_alpha/lib_protocol/apply_results.ml | 299 ++-- .../lib_protocol/apply_results.mli | 3 +- .../lib_protocol/blinded_public_key_hash.ml | 14 +- src/proto_alpha/lib_protocol/bond_id_repr.ml | 2 +- .../lib_protocol/bootstrap_storage.ml | 11 +- .../lib_protocol/bounded_history_repr.ml | 4 + .../lib_protocol/bounded_history_repr.mli | 4 + src/proto_alpha/lib_protocol/cache_repr.ml | 20 +- .../lib_protocol/carbonated_map.ml | 11 +- .../lib_protocol/carbonated_map.mli | 16 +- src/proto_alpha/lib_protocol/contract_repr.ml | 2 +- .../lib_protocol/contract_services.ml | 16 +- .../lib_protocol/contract_storage.ml | 80 +- src/proto_alpha/lib_protocol/dal_slot_repr.ml | 25 +- .../lib_protocol/delegate_cycles.ml | 23 +- .../delegate_missed_endorsements_storage.ml | 15 +- .../lib_protocol/delegate_sampler.ml | 2 +- .../delegate_slashed_deposits_storage.ml | 8 +- .../lib_protocol/delegate_storage.ml | 6 +- .../lib_protocol/dependent_bool.ml | 4 +- .../lib_protocol/dependent_bool.mli | 2 +- src/proto_alpha/lib_protocol/fees_storage.ml | 6 +- src/proto_alpha/lib_protocol/fitness_repr.ml | 8 +- .../lib_protocol/fixed_point_repr.ml | 4 +- .../lib_protocol/gas_comparable_input_size.ml | 41 +- .../lib_protocol/gas_input_size.ml | 2 +- .../lib_protocol/gas_limit_repr.mli | 1 + src/proto_alpha/lib_protocol/gas_monad.ml | 18 +- .../lib_protocol/global_constants_storage.ml | 41 +- src/proto_alpha/lib_protocol/indexable.ml | 75 +- src/proto_alpha/lib_protocol/indexable.mli | 16 +- src/proto_alpha/lib_protocol/init_storage.ml | 8 +- .../lib_protocol/lazy_storage_diff.ml | 31 +- .../lib_protocol/lazy_storage_kind.ml | 41 +- src/proto_alpha/lib_protocol/level_repr.ml | 3 +- src/proto_alpha/lib_protocol/level_storage.ml | 4 +- .../liquidity_baking_migration.ml | 8 +- src/proto_alpha/lib_protocol/main.ml | 39 +- .../lib_protocol/mempool_validation.ml | 32 +- .../lib_protocol/mempool_validation.mli | 10 +- src/proto_alpha/lib_protocol/merkle_list.ml | 57 +- src/proto_alpha/lib_protocol/merkle_list.mli | 7 +- .../lib_protocol/michelson_v1_gas.ml | 61 +- .../lib_protocol/michelson_v1_primitives.ml | 16 +- src/proto_alpha/lib_protocol/misc.ml | 38 +- .../lib_protocol/operation_repr.ml | 250 +-- .../lib_protocol/operation_repr.mli | 23 +- src/proto_alpha/lib_protocol/raw_context.ml | 76 + src/proto_alpha/lib_protocol/raw_context.mli | 2 + .../lib_protocol/raw_context_intf.ml | 129 +- src/proto_alpha/lib_protocol/round_repr.ml | 2 +- src/proto_alpha/lib_protocol/sampler.ml | 2 +- src/proto_alpha/lib_protocol/sapling_repr.ml | 2 + .../lib_protocol/sapling_storage.ml | 13 +- .../lib_protocol/sc_rollup_arith.ml | 93 +- .../lib_protocol/sc_rollup_arith.mli | 3 - .../lib_protocol/sc_rollup_errors.ml | 29 +- .../lib_protocol/sc_rollup_game_repr.ml | 2 +- ...up_inbox_merkelized_payload_hashes_repr.ml | 8 +- .../lib_protocol/sc_rollup_inbox_repr.ml | 21 +- .../sc_rollup_management_protocol.ml | 67 +- .../lib_protocol/sc_rollup_operations.ml | 32 +- .../lib_protocol/sc_rollup_proof_repr.ml | 12 +- .../lib_protocol/sc_rollup_proof_repr.mli | 2 - .../sc_rollup_refutation_storage.ml | 14 +- .../lib_protocol/sc_rollup_repr.ml | 12 +- .../lib_protocol/sc_rollup_stake_storage.ml | 20 +- .../lib_protocol/sc_rollup_storage.ml | 3 +- .../lib_protocol/sc_rollup_tick_repr.ml | 28 +- .../lib_protocol/sc_rollup_wasm.ml | 45 +- .../lib_protocol/sc_rollup_wasm.mli | 8 +- src/proto_alpha/lib_protocol/sc_rollups.ml | 47 +- src/proto_alpha/lib_protocol/sc_rollups.mli | 2 +- .../lib_protocol/script_big_map.ml | 64 +- .../lib_protocol/script_comparable.ml | 83 +- src/proto_alpha/lib_protocol/script_int.ml | 2 +- src/proto_alpha/lib_protocol/script_int.mli | 2 +- .../lib_protocol/script_interpreter.ml | 44 +- .../lib_protocol/script_interpreter_defs.ml | 641 ++++---- .../lib_protocol/script_ir_annot.ml | 2 +- .../lib_protocol/script_ir_translator.ml | 896 ++++++----- .../lib_protocol/script_ir_translator.mli | 2 + .../lib_protocol/script_ir_unparser.ml | 334 ++-- .../lib_protocol/script_ir_unparser.mli | 20 +- src/proto_alpha/lib_protocol/script_map.ml | 28 +- src/proto_alpha/lib_protocol/script_repr.ml | 15 +- src/proto_alpha/lib_protocol/script_set.ml | 16 +- src/proto_alpha/lib_protocol/script_string.ml | 2 +- .../lib_protocol/script_tc_errors.ml | 4 +- .../lib_protocol/script_typed_ir.ml | 125 +- .../lib_protocol/script_typed_ir.mli | 17 +- .../lib_protocol/script_typed_ir_size.ml | 128 +- src/proto_alpha/lib_protocol/seed_repr.ml | 18 +- src/proto_alpha/lib_protocol/seed_repr.mli | 2 +- src/proto_alpha/lib_protocol/seed_storage.ml | 3 +- .../lib_protocol/services_registration.ml | 20 +- .../lib_protocol/services_registration.mli | 6 +- .../lib_protocol/skip_list_repr.ml | 75 +- .../lib_protocol/skip_list_repr.mli | 35 +- src/proto_alpha/lib_protocol/slot_repr.ml | 6 +- src/proto_alpha/lib_protocol/storage.ml | 212 ++- src/proto_alpha/lib_protocol/storage.mli | 6 +- .../lib_protocol/storage_description.ml | 133 +- .../lib_protocol/storage_functors.ml | 40 +- src/proto_alpha/lib_protocol/storage_sigs.ml | 3 + .../lib_protocol/test/helpers/op.ml | 2 +- .../test/helpers/operation_generator.ml | 2 +- .../test/helpers/sc_rollup_helpers.ml | 4 +- src/proto_alpha/lib_protocol/tez_repr.ml | 2 +- .../lib_protocol/ticket_accounting.ml | 6 +- .../lib_protocol/ticket_hash_builder.ml | 10 +- .../lib_protocol/ticket_hash_repr.ml | 29 +- .../lib_protocol/ticket_lazy_storage_diff.ml | 26 +- .../lib_protocol/ticket_operations_diff.ml | 2 +- .../lib_protocol/ticket_scanner.ml | 79 +- .../lib_protocol/ticket_scanner.mli | 2 +- src/proto_alpha/lib_protocol/token.ml | 153 +- src/proto_alpha/lib_protocol/token.mli | 62 +- .../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 +- src/proto_alpha/lib_protocol/tx_rollup_gas.ml | 2 +- .../lib_protocol/tx_rollup_l2_address.ml | 2 +- .../lib_protocol/tx_rollup_l2_apply.ml | 141 +- .../lib_protocol/tx_rollup_l2_apply.mli | 143 +- .../lib_protocol/tx_rollup_l2_batch.ml | 25 +- .../lib_protocol/tx_rollup_l2_batch.mli | 17 +- .../lib_protocol/tx_rollup_l2_context.ml | 30 +- .../lib_protocol/tx_rollup_l2_context_sig.ml | 303 ++-- .../lib_protocol/tx_rollup_l2_storage_sig.ml | 60 +- .../lib_protocol/tx_rollup_l2_verifier.ml | 16 +- .../lib_protocol/tx_rollup_parameters.ml | 5 +- .../lib_protocol/tx_rollup_state_repr.ml | 2 +- src/proto_alpha/lib_protocol/validate.ml | 215 ++- .../lib_protocol/zk_rollup_apply.ml | 10 +- .../lib_protocol/zk_rollup_parameters.ml | 2 +- src/proto_demo_counter/lib_protocol/main.ml | 4 +- src/proto_demo_noops/lib_protocol/main.ml | 4 +- 433 files changed, 14000 insertions(+), 10299 deletions(-) diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index 8bd5c0800f281..e97b956e6752f 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_V3.ml b/src/lib_protocol_environment/environment_V3.ml index 9905a5b8c1f64..89b1ff31ace64 100644 --- a/src/lib_protocol_environment/environment_V3.ml +++ b/src/lib_protocol_environment/environment_V3.ml @@ -1214,10 +1214,12 @@ struct type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/environment_V4.ml b/src/lib_protocol_environment/environment_V4.ml index c883b5052f5cc..c0353f2040751 100644 --- a/src/lib_protocol_environment/environment_V4.ml +++ b/src/lib_protocol_environment/environment_V4.ml @@ -1231,10 +1231,12 @@ struct type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/environment_V5.ml b/src/lib_protocol_environment/environment_V5.ml index 8da55b05f4523..a5b96fbb47e41 100644 --- a/src/lib_protocol_environment/environment_V5.ml +++ b/src/lib_protocol_environment/environment_V5.ml @@ -1208,10 +1208,12 @@ struct type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index e835c768610cf..e48d98fe85101 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1056,6 +1056,18 @@ struct input_request : input_request; } + module type S = sig + type tree + + val compute_step : tree -> tree Lwt.t + + val set_input_step : input -> string -> tree -> tree Lwt.t + + val get_output : output -> tree -> string Lwt.t + + val get_info : tree -> info Lwt.t + end + module Make (Tree : Context.TREE with type key = string list and type value = bytes) = struct @@ -1303,10 +1315,12 @@ struct type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/environment_V7.ml b/src/lib_protocol_environment/environment_V7.ml index 4ffe74e9d4401..d5957fb26228b 100644 --- a/src/lib_protocol_environment/environment_V7.ml +++ b/src/lib_protocol_environment/environment_V7.ml @@ -1061,6 +1061,18 @@ struct input_request : input_request; } + module type S = sig + type tree + + val compute_step : tree -> tree Lwt.t + + val set_input_step : input -> string -> tree -> tree Lwt.t + + val get_output : output -> tree -> string Lwt.t + + val get_info : tree -> info Lwt.t + end + module Make (Tree : Context.TREE with type key = string list and type value = bytes) = struct diff --git a/src/lib_protocol_environment/environment_V8.ml b/src/lib_protocol_environment/environment_V8.ml index 699fbb819a32e..c0d0863b5ad8e 100644 --- a/src/lib_protocol_environment/environment_V8.ml +++ b/src/lib_protocol_environment/environment_V8.ml @@ -1090,6 +1090,22 @@ struct input_request : input_request; } + module type S = sig + type tree + + val install_boot_sector : string -> tree -> tree Lwt.t + + val compute_step : tree -> tree Lwt.t + + val set_input_step : input -> string -> tree -> tree Lwt.t + + val reveal_step : bytes -> tree -> tree Lwt.t + + val get_output : output -> tree -> string option Lwt.t + + val get_info : tree -> info Lwt.t + end + module Make (Tree : Context.TREE with type key = string list and type value = bytes) = struct diff --git a/src/lib_protocol_environment/environment_context_intf.ml b/src/lib_protocol_environment/environment_context_intf.ml index 66dca648998cd..f704ac56fecf7 100644 --- a/src/lib_protocol_environment/environment_context_intf.ml +++ b/src/lib_protocol_environment/environment_context_intf.ml @@ -212,6 +212,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/environment_protocol_T.ml b/src/lib_protocol_environment/environment_protocol_T.ml index 61b207bfb12ee..0cebe99b59fab 100644 --- a/src/lib_protocol_environment/environment_protocol_T.ml +++ b/src/lib_protocol_environment/environment_protocol_T.ml @@ -187,10 +187,12 @@ module V0toV7 type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Tezos_crypto.Operation_hash.t * operation -> new_operation:Tezos_crypto.Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/environment_protocol_T_V7.ml b/src/lib_protocol_environment/environment_protocol_T_V7.ml index 2d419e8404178..3bb1aa782499d 100644 --- a/src/lib_protocol_environment/environment_protocol_T_V7.ml +++ b/src/lib_protocol_environment/environment_protocol_T_V7.ml @@ -160,10 +160,12 @@ module type T = sig type validation_info + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Tezos_crypto.Operation_hash.t * operation -> new_operation:Tezos_crypto.Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/environment_protocol_T_test.ml b/src/lib_protocol_environment/environment_protocol_T_test.ml index 336d26ffa5781..a87731a65a8ce 100644 --- a/src/lib_protocol_environment/environment_protocol_T_test.ml +++ b/src/lib_protocol_environment/environment_protocol_T_test.ml @@ -122,10 +122,12 @@ module Mock_all_unit : type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Tezos_crypto.Operation_hash.t * operation -> new_operation:Tezos_crypto.Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/sigs/v4.ml b/src/lib_protocol_environment/sigs/v4.ml index 62fecfd963770..d45a8f269baf8 100644 --- a/src/lib_protocol_environment/sigs/v4.ml +++ b/src/lib_protocol_environment/sigs/v4.ml @@ -7817,6 +7817,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 @@ -7899,7 +7903,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 895f6d525d4df..7171cdd5adbdb 100644 --- a/src/lib_protocol_environment/sigs/v5.in.ml +++ b/src/lib_protocol_environment/sigs/v5.in.ml @@ -3,125 +3,128 @@ 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 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 ec1cede6ef504..411dd7854f554 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" @@ -8767,8 +8769,8 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 78 "v5.in.ml" - +# 79 "v5.in.ml" + [@@coq_plain_module] module Blake2B : sig # 1 "v5/blake2B.mli" @@ -8832,8 +8834,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" @@ -8870,8 +8872,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" @@ -8966,8 +8968,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" @@ -9000,8 +9002,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" @@ -9034,8 +9036,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" @@ -9068,8 +9070,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" @@ -9100,8 +9102,8 @@ end include S.HASH end -# 92 "v5.in.ml" - +# 93 "v5.in.ml" + [@@coq_plain_module] module Signature : sig # 1 "v5/signature.mli" @@ -9152,8 +9154,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" @@ -9185,8 +9187,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" @@ -9218,8 +9220,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" @@ -9251,8 +9253,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" @@ -9284,8 +9287,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" @@ -9317,8 +9321,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" @@ -9370,8 +9374,8 @@ end type version = Version.t end -# 106 "v5.in.ml" - +# 109 "v5.in.ml" + [@@coq_plain_module] module Sapling : sig # 1 "v5/sapling.mli" @@ -9518,8 +9522,8 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 108 "v5.in.ml" - +# 111 "v5.in.ml" + [@@coq_plain_module] module Timelock : sig # 1 "v5/timelock.mli" @@ -9577,8 +9581,8 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 110 "v5.in.ml" - +# 113 "v5.in.ml" + [@@coq_plain_module] module Micheline : sig # 1 "v5/micheline.mli" @@ -9637,8 +9641,8 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 112 "v5.in.ml" - +# 115 "v5.in.ml" + [@@coq_plain_module] module Block_header : sig # 1 "v5/block_header.mli" @@ -9694,8 +9698,8 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 114 "v5.in.ml" - +# 117 "v5.in.ml" + [@@coq_plain_module] module Bounded : sig # 1 "v5/bounded.mli" @@ -9767,11 +9771,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 -# 116 "v5.in.ml" - +# 119 "v5.in.ml" + [@@coq_plain_module] module Fitness : sig # 1 "v5/fitness.mli" @@ -9804,8 +9808,8 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 118 "v5.in.ml" - +# 121 "v5.in.ml" + [@@coq_plain_module] module Operation : sig # 1 "v5/operation.mli" @@ -9848,8 +9852,8 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 120 "v5.in.ml" - +# 123 "v5.in.ml" + [@@coq_plain_module] module Context : sig # 1 "v5/context.mli" @@ -9994,6 +9998,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 @@ -10485,8 +10490,8 @@ module Cache : and type key = cache_key and type value = cache_value end -# 122 "v5.in.ml" - +# 125 "v5.in.ml" + [@@coq_plain_module] module Updater : sig # 1 "v5/updater.mli" @@ -10786,8 +10791,8 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 124 "v5.in.ml" - +# 127 "v5.in.ml" + [@@coq_plain_module] module RPC_context : sig # 1 "v5/RPC_context.mli" @@ -10941,6 +10946,6 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 126 "v5.in.ml" - +# 129 "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/lib_protocol_environment/sigs/v6.in.ml b/src/lib_protocol_environment/sigs/v6.in.ml index 3d345550a8c70..07e405f29854d 100644 --- a/src/lib_protocol_environment/sigs/v6.in.ml +++ b/src/lib_protocol_environment/sigs/v6.in.ml @@ -3,131 +3,134 @@ module type T = sig include Tezos_protocol_environment_sigs_internals.CamlinternalFormatBasics end - module Pervasives : [%sig "v6/pervasives.mli"] + module Pervasives : [%sig "v6/pervasives.mli"] [@@coq_plain_module] open Pervasives - module Either : [%sig "v6/either.mli"] + module Either : [%sig "v6/either.mli"] [@@coq_plain_module] - module String : [%sig "v6/string.mli"] + module String : [%sig "v6/string.mli"] [@@coq_plain_module] - module Char : [%sig "v6/char.mli"] + module Char : [%sig "v6/char.mli"] [@@coq_plain_module] - module Bytes : [%sig "v6/bytes.mli"] + module Bytes : [%sig "v6/bytes.mli"] [@@coq_plain_module] - module Int32 : [%sig "v6/int32.mli"] + module Int32 : [%sig "v6/int32.mli"] [@@coq_plain_module] - module Int64 : [%sig "v6/int64.mli"] + module Int64 : [%sig "v6/int64.mli"] [@@coq_plain_module] - module Format : [%sig "v6/format.mli"] + module Format : [%sig "v6/format.mli"] [@@coq_plain_module] - module Logging : [%sig "v6/logging.mli"] + module Logging : [%sig "v6/logging.mli"] [@@coq_plain_module] - module Hex : [%sig "v6/hex.mli"] + module Hex : [%sig "v6/hex.mli"] [@@coq_plain_module] - module Z : [%sig "v6/z.mli"] + module Z : [%sig "v6/z.mli"] [@@coq_plain_module] - module Lwt : [%sig "v6/lwt.mli"] + module Lwt : [%sig "v6/lwt.mli"] [@@coq_plain_module] - module Data_encoding : [%sig "v6/data_encoding.mli"] + module Data_encoding : [%sig "v6/data_encoding.mli"] [@@coq_plain_module] - module Raw_hashes : [%sig "v6/raw_hashes.mli"] + module Raw_hashes : [%sig "v6/raw_hashes.mli"] [@@coq_plain_module] - module Compare : [%sig "v6/compare.mli"] + module Compare : [%sig "v6/compare.mli"] [@@coq_plain_module] - module Time : [%sig "v6/time.mli"] + module Time : [%sig "v6/time.mli"] [@@coq_plain_module] - module TzEndian : [%sig "v6/tzEndian.mli"] + module TzEndian : [%sig "v6/tzEndian.mli"] [@@coq_plain_module] - module Bits : [%sig "v6/bits.mli"] + module Bits : [%sig "v6/bits.mli"] [@@coq_plain_module] module Equality_witness : [%sig "v6/equality_witness.mli"] + [@@coq_plain_module] - module FallbackArray : [%sig "v6/fallbackArray.mli"] + module FallbackArray : [%sig "v6/fallbackArray.mli"] [@@coq_plain_module] - module Error_monad : [%sig "v6/error_monad.mli"] + module Error_monad : [%sig "v6/error_monad.mli"] [@@coq_plain_module] open Error_monad - module Seq : [%sig "v6/seq.mli"] + module Seq : [%sig "v6/seq.mli"] [@@coq_plain_module] - module List : [%sig "v6/list.mli"] + module List : [%sig "v6/list.mli"] [@@coq_plain_module] - module Set : [%sig "v6/set.mli"] + module Set : [%sig "v6/set.mli"] [@@coq_plain_module] - module Map : [%sig "v6/map.mli"] + module Map : [%sig "v6/map.mli"] [@@coq_plain_module] - module Option : [%sig "v6/option.mli"] + module Option : [%sig "v6/option.mli"] [@@coq_plain_module] - module Result : [%sig "v6/result.mli"] + module Result : [%sig "v6/result.mli"] [@@coq_plain_module] - module RPC_arg : [%sig "v6/RPC_arg.mli"] + module RPC_arg : [%sig "v6/RPC_arg.mli"] [@@coq_plain_module] - module RPC_path : [%sig "v6/RPC_path.mli"] + module RPC_path : [%sig "v6/RPC_path.mli"] [@@coq_plain_module] - module RPC_query : [%sig "v6/RPC_query.mli"] + module RPC_query : [%sig "v6/RPC_query.mli"] [@@coq_plain_module] - module RPC_service : [%sig "v6/RPC_service.mli"] + module RPC_service : [%sig "v6/RPC_service.mli"] [@@coq_plain_module] - module RPC_answer : [%sig "v6/RPC_answer.mli"] + module RPC_answer : [%sig "v6/RPC_answer.mli"] [@@coq_plain_module] - module RPC_directory : [%sig "v6/RPC_directory.mli"] + module RPC_directory : [%sig "v6/RPC_directory.mli"] [@@coq_plain_module] - module Base58 : [%sig "v6/base58.mli"] + module Base58 : [%sig "v6/base58.mli"] [@@coq_plain_module] - module S : [%sig "v6/s.mli"] + module S : [%sig "v6/s.mli"] [@@coq_plain_module] - module Blake2B : [%sig "v6/blake2B.mli"] + module Blake2B : [%sig "v6/blake2B.mli"] [@@coq_plain_module] - module Bls12_381 : [%sig "v6/bls12_381.mli"] + module Bls12_381 : [%sig "v6/bls12_381.mli"] [@@coq_plain_module] - module Bls_signature : [%sig "v6/bls_signature.mli"] + module Bls_signature : [%sig "v6/bls_signature.mli"] [@@coq_plain_module] - module Ed25519 : [%sig "v6/ed25519.mli"] + module Ed25519 : [%sig "v6/ed25519.mli"] [@@coq_plain_module] - module Secp256k1 : [%sig "v6/secp256k1.mli"] + module Secp256k1 : [%sig "v6/secp256k1.mli"] [@@coq_plain_module] - module P256 : [%sig "v6/p256.mli"] + module P256 : [%sig "v6/p256.mli"] [@@coq_plain_module] - module Chain_id : [%sig "v6/chain_id.mli"] + module Chain_id : [%sig "v6/chain_id.mli"] [@@coq_plain_module] - module Signature : [%sig "v6/signature.mli"] + module Signature : [%sig "v6/signature.mli"] [@@coq_plain_module] - module Block_hash : [%sig "v6/block_hash.mli"] + module Block_hash : [%sig "v6/block_hash.mli"] [@@coq_plain_module] - module Operation_hash : [%sig "v6/operation_hash.mli"] + module Operation_hash : [%sig "v6/operation_hash.mli"] [@@coq_plain_module] module Operation_list_hash : [%sig "v6/operation_list_hash.mli"] + [@@coq_plain_module] module Operation_list_list_hash : [%sig "v6/operation_list_list_hash.mli"] + [@@coq_plain_module] - module Protocol_hash : [%sig "v6/protocol_hash.mli"] + module Protocol_hash : [%sig "v6/protocol_hash.mli"] [@@coq_plain_module] - module Context_hash : [%sig "v6/context_hash.mli"] + module Context_hash : [%sig "v6/context_hash.mli"] [@@coq_plain_module] - module Sapling : [%sig "v6/sapling.mli"] + module Sapling : [%sig "v6/sapling.mli"] [@@coq_plain_module] - module Timelock : [%sig "v6/timelock.mli"] + module Timelock : [%sig "v6/timelock.mli"] [@@coq_plain_module] - module Vdf : [%sig "v6/vdf.mli"] + module Vdf : [%sig "v6/vdf.mli"] [@@coq_plain_module] - module Micheline : [%sig "v6/micheline.mli"] + module Micheline : [%sig "v6/micheline.mli"] [@@coq_plain_module] - module Block_header : [%sig "v6/block_header.mli"] + module Block_header : [%sig "v6/block_header.mli"] [@@coq_plain_module] - module Bounded : [%sig "v6/bounded.mli"] + module Bounded : [%sig "v6/bounded.mli"] [@@coq_plain_module] - module Fitness : [%sig "v6/fitness.mli"] + module Fitness : [%sig "v6/fitness.mli"] [@@coq_plain_module] - module Operation : [%sig "v6/operation.mli"] + module Operation : [%sig "v6/operation.mli"] [@@coq_plain_module] - module Context : [%sig "v6/context.mli"] + module Context : [%sig "v6/context.mli"] [@@coq_plain_module] - module Updater : [%sig "v6/updater.mli"] + module Updater : [%sig "v6/updater.mli"] [@@coq_plain_module] - module RPC_context : [%sig "v6/RPC_context.mli"] + module RPC_context : [%sig "v6/RPC_context.mli"] [@@coq_plain_module] - module Wasm_2_0_0 : [%sig "v6/wasm_2_0_0.mli"] + module Wasm_2_0_0 : [%sig "v6/wasm_2_0_0.mli"] [@@coq_plain_module] - module Plonk : [%sig "v6/plonk.mli"] + module Plonk : [%sig "v6/plonk.mli"] [@@coq_plain_module] end diff --git a/src/lib_protocol_environment/sigs/v6.ml b/src/lib_protocol_environment/sigs/v6.ml index 682cca121978b..eb6a49e46ec2f 100644 --- a/src/lib_protocol_environment/sigs/v6.ml +++ b/src/lib_protocol_environment/sigs/v6.ml @@ -492,7 +492,7 @@ val ( ^^ ) : *) end # 6 "v6.in.ml" - + [@@coq_plain_module] open Pervasives @@ -574,7 +574,7 @@ val compare : [Left _] values are smaller than [Right _] values. *) end # 10 "v6.in.ml" - + [@@coq_plain_module] module String : sig # 1 "v6/string.mli" @@ -822,7 +822,7 @@ val split_on_char: char -> string -> string list *) end # 12 "v6.in.ml" - + [@@coq_plain_module] module Char : sig # 1 "v6/char.mli" @@ -882,7 +882,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 14 "v6.in.ml" - + [@@coq_plain_module] module Bytes : sig # 1 "v6/bytes.mli" @@ -1146,7 +1146,7 @@ val equal: t -> t -> bool @since 4.03.0 (4.05.0 in BytesLabels) *) end # 16 "v6.in.ml" - + [@@coq_plain_module] module Int32 : sig # 1 "v6/int32.mli" @@ -1297,7 +1297,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 18 "v6.in.ml" - + [@@coq_plain_module] module Int64 : sig # 1 "v6/int64.mli" @@ -1456,7 +1456,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 20 "v6.in.ml" - + [@@coq_plain_module] module Format : sig # 1 "v6/format.mli" @@ -2220,7 +2220,7 @@ val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b *) end # 22 "v6.in.ml" - + [@@coq_plain_module] module Logging : sig # 1 "v6/logging.mli" @@ -2270,7 +2270,7 @@ val log : level -> ('a, Format.formatter, unit, unit) format4 -> 'a val log_string : level -> string -> unit end # 24 "v6.in.ml" - + [@@coq_plain_module] module Hex : sig # 1 "v6/hex.mli" @@ -2358,7 +2358,7 @@ val show : t -> string a string. *) end # 26 "v6.in.ml" - + [@@coq_plain_module] module Z : sig # 1 "v6/z.mli" @@ -2832,7 +2832,7 @@ external of_bits: string -> t = "ml_z_of_bits" *) end # 28 "v6.in.ml" - + [@@coq_plain_module] module Lwt : sig # 1 "v6/lwt.mli" @@ -3103,7 +3103,7 @@ val return_false : bool t {!Lwt.return}[ false]. *) end # 30 "v6.in.ml" - + [@@coq_plain_module] module Data_encoding : sig # 1 "v6/data_encoding.mli" @@ -4592,7 +4592,7 @@ module Binary : sig end end # 32 "v6.in.ml" - + [@@coq_plain_module] module Raw_hashes : sig # 1 "v6/raw_hashes.mli" @@ -4634,7 +4634,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end # 34 "v6.in.ml" - + [@@coq_plain_module] module Compare : sig # 1 "v6/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 "v6.in.ml" - + [@@coq_plain_module] module Time : sig # 1 "v6/time.mli" @@ -4966,7 +4967,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end # 38 "v6.in.ml" - + [@@coq_plain_module] module TzEndian : sig # 1 "v6/tzEndian.mli" @@ -5032,7 +5033,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end # 40 "v6.in.ml" - + [@@coq_plain_module] module Bits : sig # 1 "v6/bits.mli" @@ -5069,7 +5070,7 @@ end val numbits : int -> int end # 42 "v6.in.ml" - + [@@coq_plain_module] module Equality_witness : sig # 1 "v6/equality_witness.mli" @@ -5138,6 +5139,7 @@ val hash : 'a t -> int end # 44 "v6.in.ml" + [@@coq_plain_module] module FallbackArray : sig # 1 "v6/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 "v6.in.ml" - +# 47 "v6.in.ml" + [@@coq_plain_module] module Error_monad : sig # 1 "v6/error_monad.mli" @@ -5656,8 +5658,8 @@ module Lwt_tzresult_syntax : sig ('a * 'b, 'error trace) result Lwt.t end end -# 48 "v6.in.ml" - +# 49 "v6.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 "v6.in.ml" - +# 53 "v6.in.ml" + [@@coq_plain_module] module List : sig # 1 "v6/list.mli" @@ -7115,8 +7117,8 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 54 "v6.in.ml" - +# 55 "v6.in.ml" + [@@coq_plain_module] module Set : sig # 1 "v6/set.mli" @@ -7264,8 +7266,8 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 56 "v6.in.ml" - +# 57 "v6.in.ml" + [@@coq_plain_module] module Map : sig # 1 "v6/map.mli" @@ -7433,8 +7435,8 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 58 "v6.in.ml" - +# 59 "v6.in.ml" + [@@coq_plain_module] module Option : sig # 1 "v6/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 "v6.in.ml" - +# 61 "v6.in.ml" + [@@coq_plain_module] module Result : sig # 1 "v6/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 "v6.in.ml" - +# 63 "v6.in.ml" + [@@coq_plain_module] module RPC_arg : sig # 1 "v6/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 "v6.in.ml" - +# 65 "v6.in.ml" + [@@coq_plain_module] module RPC_path : sig # 1 "v6/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 "v6.in.ml" - +# 67 "v6.in.ml" + [@@coq_plain_module] module RPC_query : sig # 1 "v6/RPC_query.mli" @@ -7945,8 +7947,8 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 68 "v6.in.ml" - +# 69 "v6.in.ml" + [@@coq_plain_module] module RPC_service : sig # 1 "v6/RPC_service.mli" @@ -8022,8 +8024,8 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 70 "v6.in.ml" - +# 71 "v6.in.ml" + [@@coq_plain_module] module RPC_answer : sig # 1 "v6/RPC_answer.mli" @@ -8083,8 +8085,8 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 72 "v6.in.ml" - +# 73 "v6.in.ml" + [@@coq_plain_module] module RPC_directory : sig # 1 "v6/RPC_directory.mli" @@ -8348,8 +8350,8 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 74 "v6.in.ml" - +# 75 "v6.in.ml" + [@@coq_plain_module] module Base58 : sig # 1 "v6/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 "v6.in.ml" - +# 77 "v6.in.ml" + [@@coq_plain_module] module S : sig # 1 "v6/s.mli" @@ -8767,8 +8769,8 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 78 "v6.in.ml" - +# 79 "v6.in.ml" + [@@coq_plain_module] module Blake2B : sig # 1 "v6/blake2B.mli" @@ -8832,8 +8834,8 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 80 "v6.in.ml" - +# 81 "v6.in.ml" + [@@coq_plain_module] module Bls12_381 : sig # 1 "v6/bls12_381.mli" @@ -8870,8 +8872,8 @@ module G2 : S.CURVE with type Scalar.t = Fr.t val pairing_check : (G1.t * G2.t) list -> bool end -# 82 "v6.in.ml" - +# 83 "v6.in.ml" + [@@coq_plain_module] module Bls_signature : sig # 1 "v6/bls_signature.mli" @@ -8966,8 +8968,8 @@ val verify : pk -> Bytes.t -> signature -> bool val aggregate_verify : (pk * Bytes.t) list -> signature -> bool end -# 84 "v6.in.ml" - +# 85 "v6.in.ml" + [@@coq_plain_module] module Ed25519 : sig # 1 "v6/ed25519.mli" @@ -9000,8 +9002,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 86 "v6.in.ml" - +# 87 "v6.in.ml" + [@@coq_plain_module] module Secp256k1 : sig # 1 "v6/secp256k1.mli" @@ -9034,8 +9036,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v6.in.ml" - +# 89 "v6.in.ml" + [@@coq_plain_module] module P256 : sig # 1 "v6/p256.mli" @@ -9068,8 +9070,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v6.in.ml" - +# 91 "v6.in.ml" + [@@coq_plain_module] module Chain_id : sig # 1 "v6/chain_id.mli" @@ -9100,8 +9102,8 @@ end include S.HASH end -# 92 "v6.in.ml" - +# 93 "v6.in.ml" + [@@coq_plain_module] module Signature : sig # 1 "v6/signature.mli" @@ -9152,8 +9154,8 @@ include and type Public_key.t = public_key and type watermark := watermark end -# 94 "v6.in.ml" - +# 95 "v6.in.ml" + [@@coq_plain_module] module Block_hash : sig # 1 "v6/block_hash.mli" @@ -9185,8 +9187,8 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 96 "v6.in.ml" - +# 97 "v6.in.ml" + [@@coq_plain_module] module Operation_hash : sig # 1 "v6/operation_hash.mli" @@ -9218,8 +9220,8 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 98 "v6.in.ml" - +# 99 "v6.in.ml" + [@@coq_plain_module] module Operation_list_hash : sig # 1 "v6/operation_list_hash.mli" @@ -9251,8 +9253,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 100 "v6.in.ml" +# 101 "v6.in.ml" + [@@coq_plain_module] module Operation_list_list_hash : sig # 1 "v6/operation_list_list_hash.mli" @@ -9284,8 +9287,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 102 "v6.in.ml" +# 104 "v6.in.ml" + [@@coq_plain_module] module Protocol_hash : sig # 1 "v6/protocol_hash.mli" @@ -9317,8 +9321,8 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 104 "v6.in.ml" - +# 107 "v6.in.ml" + [@@coq_plain_module] module Context_hash : sig # 1 "v6/context_hash.mli" @@ -9370,8 +9374,8 @@ end type version = Version.t end -# 106 "v6.in.ml" - +# 109 "v6.in.ml" + [@@coq_plain_module] module Sapling : sig # 1 "v6/sapling.mli" @@ -9518,8 +9522,8 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 108 "v6.in.ml" - +# 111 "v6.in.ml" + [@@coq_plain_module] module Timelock : sig # 1 "v6/timelock.mli" @@ -9577,8 +9581,8 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 110 "v6.in.ml" - +# 113 "v6.in.ml" + [@@coq_plain_module] module Vdf : sig # 1 "v6/vdf.mli" @@ -9665,8 +9669,8 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 112 "v6.in.ml" - +# 115 "v6.in.ml" + [@@coq_plain_module] module Micheline : sig # 1 "v6/micheline.mli" @@ -9725,8 +9729,8 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 114 "v6.in.ml" - +# 117 "v6.in.ml" + [@@coq_plain_module] module Block_header : sig # 1 "v6/block_header.mli" @@ -9782,8 +9786,8 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 116 "v6.in.ml" - +# 119 "v6.in.ml" + [@@coq_plain_module] module Bounded : sig # 1 "v6/bounded.mli" @@ -9855,13 +9859,13 @@ 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 module NonNegative : S end end -# 118 "v6.in.ml" - +# 121 "v6.in.ml" + [@@coq_plain_module] module Fitness : sig # 1 "v6/fitness.mli" @@ -9894,8 +9898,8 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 120 "v6.in.ml" - +# 123 "v6.in.ml" + [@@coq_plain_module] module Operation : sig # 1 "v6/operation.mli" @@ -9938,8 +9942,8 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 122 "v6.in.ml" - +# 125 "v6.in.ml" + [@@coq_plain_module] module Context : sig # 1 "v6/context.mli" @@ -10575,8 +10579,8 @@ module Cache : and type key = cache_key and type value = cache_value end -# 124 "v6.in.ml" - +# 127 "v6.in.ml" + [@@coq_plain_module] module Updater : sig # 1 "v6/updater.mli" @@ -10880,8 +10884,8 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 126 "v6.in.ml" - +# 129 "v6.in.ml" + [@@coq_plain_module] module RPC_context : sig # 1 "v6/RPC_context.mli" @@ -11035,8 +11039,8 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 128 "v6.in.ml" - +# 131 "v6.in.ml" + [@@coq_plain_module] module Wasm_2_0_0 : sig # 1 "v6/wasm_2_0_0.mli" @@ -11077,19 +11081,24 @@ type info = { input_request : input_request; } -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val compute_step : Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree - val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t + val compute_step : tree -> tree Lwt.t - val get_output : output -> Tree.tree -> string Lwt.t + val set_input_step : input -> string -> tree -> tree Lwt.t - val get_info : Tree.tree -> info Lwt.t -end + val get_output : output -> tree -> string Lwt.t + + val get_info : tree -> info Lwt.t end -# 130 "v6.in.ml" +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree +end +# 133 "v6.in.ml" + [@@coq_plain_module] module Plonk : sig # 1 "v6/plonk.mli" @@ -11173,6 +11182,6 @@ val verify_multi_circuits : proof -> bool end -# 132 "v6.in.ml" - +# 135 "v6.in.ml" + [@@coq_plain_module] end diff --git a/src/lib_protocol_environment/sigs/v6/bounded.mli b/src/lib_protocol_environment/sigs/v6/bounded.mli index 58b341f6f49ac..7ac7b0d1eb9ae 100644 --- a/src/lib_protocol_environment/sigs/v6/bounded.mli +++ b/src/lib_protocol_environment/sigs/v6/bounded.mli @@ -66,7 +66,7 @@ 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 module NonNegative : S end diff --git a/src/lib_protocol_environment/sigs/v6/compare.mli b/src/lib_protocol_environment/sigs/v6/compare.mli index 0437dd1e23de5..38f5f19e98bd3 100644 --- a/src/lib_protocol_environment/sigs/v6/compare.mli +++ b/src/lib_protocol_environment/sigs/v6/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/v6/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli index 3d9b45fea9c5c..a69368778c1c9 100644 --- a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli @@ -35,13 +35,18 @@ type info = { input_request : input_request; } -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val compute_step : Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree + + val compute_step : tree -> tree Lwt.t - val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t + val set_input_step : input -> string -> tree -> tree Lwt.t - val get_output : output -> Tree.tree -> string Lwt.t + val get_output : output -> tree -> string Lwt.t - val get_info : Tree.tree -> info Lwt.t + val get_info : tree -> info Lwt.t end + +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree diff --git a/src/lib_protocol_environment/sigs/v7.in.ml b/src/lib_protocol_environment/sigs/v7.in.ml index 571d23da0ccbc..7533c3071e016 100644 --- a/src/lib_protocol_environment/sigs/v7.in.ml +++ b/src/lib_protocol_environment/sigs/v7.in.ml @@ -3,135 +3,138 @@ module type T = sig include Tezos_protocol_environment_sigs_internals.CamlinternalFormatBasics end - module Pervasives : [%sig "v7/pervasives.mli"] + module Pervasives : [%sig "v7/pervasives.mli"] [@@coq_plain_module] open Pervasives - module Either : [%sig "v7/either.mli"] + module Either : [%sig "v7/either.mli"] [@@coq_plain_module] - module String : [%sig "v7/string.mli"] + module String : [%sig "v7/string.mli"] [@@coq_plain_module] - module Char : [%sig "v7/char.mli"] + module Char : [%sig "v7/char.mli"] [@@coq_plain_module] - module Bytes : [%sig "v7/bytes.mli"] + module Bytes : [%sig "v7/bytes.mli"] [@@coq_plain_module] - module Int32 : [%sig "v7/int32.mli"] + module Int32 : [%sig "v7/int32.mli"] [@@coq_plain_module] - module Int64 : [%sig "v7/int64.mli"] + module Int64 : [%sig "v7/int64.mli"] [@@coq_plain_module] - module Format : [%sig "v7/format.mli"] + module Format : [%sig "v7/format.mli"] [@@coq_plain_module] - module Logging : [%sig "v7/logging.mli"] + module Logging : [%sig "v7/logging.mli"] [@@coq_plain_module] - module Hex : [%sig "v7/hex.mli"] + module Hex : [%sig "v7/hex.mli"] [@@coq_plain_module] - module Z : [%sig "v7/z.mli"] + module Z : [%sig "v7/z.mli"] [@@coq_plain_module] - module Q : [%sig "v7/q.mli"] + module Q : [%sig "v7/q.mli"] [@@coq_plain_module] - module Lwt : [%sig "v7/lwt.mli"] + module Lwt : [%sig "v7/lwt.mli"] [@@coq_plain_module] - module Data_encoding : [%sig "v7/data_encoding.mli"] + module Data_encoding : [%sig "v7/data_encoding.mli"] [@@coq_plain_module] - module Raw_hashes : [%sig "v7/raw_hashes.mli"] + module Raw_hashes : [%sig "v7/raw_hashes.mli"] [@@coq_plain_module] - module Compare : [%sig "v7/compare.mli"] + module Compare : [%sig "v7/compare.mli"] [@@coq_plain_module] - module Time : [%sig "v7/time.mli"] + module Time : [%sig "v7/time.mli"] [@@coq_plain_module] - module TzEndian : [%sig "v7/tzEndian.mli"] + module TzEndian : [%sig "v7/tzEndian.mli"] [@@coq_plain_module] - module Bits : [%sig "v7/bits.mli"] + module Bits : [%sig "v7/bits.mli"] [@@coq_plain_module] module Equality_witness : [%sig "v7/equality_witness.mli"] + [@@coq_plain_module] - module FallbackArray : [%sig "v7/fallbackArray.mli"] + module FallbackArray : [%sig "v7/fallbackArray.mli"] [@@coq_plain_module] - module Error_monad : [%sig "v7/error_monad.mli"] + module Error_monad : [%sig "v7/error_monad.mli"] [@@coq_plain_module] open Error_monad - module Seq : [%sig "v7/seq.mli"] + module Seq : [%sig "v7/seq.mli"] [@@coq_plain_module] - module List : [%sig "v7/list.mli"] + module List : [%sig "v7/list.mli"] [@@coq_plain_module] - module Array : [%sig "v7/array.mli"] + module Array : [%sig "v7/array.mli"] [@@coq_plain_module] - module Set : [%sig "v7/set.mli"] + module Set : [%sig "v7/set.mli"] [@@coq_plain_module] - module Map : [%sig "v7/map.mli"] + module Map : [%sig "v7/map.mli"] [@@coq_plain_module] - module Option : [%sig "v7/option.mli"] + module Option : [%sig "v7/option.mli"] [@@coq_plain_module] - module Result : [%sig "v7/result.mli"] + module Result : [%sig "v7/result.mli"] [@@coq_plain_module] - module RPC_arg : [%sig "v7/RPC_arg.mli"] + module RPC_arg : [%sig "v7/RPC_arg.mli"] [@@coq_plain_module] - module RPC_path : [%sig "v7/RPC_path.mli"] + module RPC_path : [%sig "v7/RPC_path.mli"] [@@coq_plain_module] - module RPC_query : [%sig "v7/RPC_query.mli"] + module RPC_query : [%sig "v7/RPC_query.mli"] [@@coq_plain_module] - module RPC_service : [%sig "v7/RPC_service.mli"] + module RPC_service : [%sig "v7/RPC_service.mli"] [@@coq_plain_module] - module RPC_answer : [%sig "v7/RPC_answer.mli"] + module RPC_answer : [%sig "v7/RPC_answer.mli"] [@@coq_plain_module] - module RPC_directory : [%sig "v7/RPC_directory.mli"] + module RPC_directory : [%sig "v7/RPC_directory.mli"] [@@coq_plain_module] - module Base58 : [%sig "v7/base58.mli"] + module Base58 : [%sig "v7/base58.mli"] [@@coq_plain_module] - module S : [%sig "v7/s.mli"] + module S : [%sig "v7/s.mli"] [@@coq_plain_module] - module Blake2B : [%sig "v7/blake2B.mli"] + module Blake2B : [%sig "v7/blake2B.mli"] [@@coq_plain_module] - module Bls : [%sig "v7/bls.mli"] + module Bls : [%sig "v7/bls.mli"] [@@coq_plain_module] - module Ed25519 : [%sig "v7/ed25519.mli"] + module Ed25519 : [%sig "v7/ed25519.mli"] [@@coq_plain_module] - module Secp256k1 : [%sig "v7/secp256k1.mli"] + module Secp256k1 : [%sig "v7/secp256k1.mli"] [@@coq_plain_module] - module P256 : [%sig "v7/p256.mli"] + module P256 : [%sig "v7/p256.mli"] [@@coq_plain_module] - module Chain_id : [%sig "v7/chain_id.mli"] + module Chain_id : [%sig "v7/chain_id.mli"] [@@coq_plain_module] - module Signature : [%sig "v7/signature.mli"] + module Signature : [%sig "v7/signature.mli"] [@@coq_plain_module] - module Block_hash : [%sig "v7/block_hash.mli"] + module Block_hash : [%sig "v7/block_hash.mli"] [@@coq_plain_module] - module Operation_hash : [%sig "v7/operation_hash.mli"] + module Operation_hash : [%sig "v7/operation_hash.mli"] [@@coq_plain_module] module Operation_list_hash : [%sig "v7/operation_list_hash.mli"] + [@@coq_plain_module] module Operation_list_list_hash : [%sig "v7/operation_list_list_hash.mli"] + [@@coq_plain_module] - module Protocol_hash : [%sig "v7/protocol_hash.mli"] + module Protocol_hash : [%sig "v7/protocol_hash.mli"] [@@coq_plain_module] - module Context_hash : [%sig "v7/context_hash.mli"] + module Context_hash : [%sig "v7/context_hash.mli"] [@@coq_plain_module] - module Sapling : [%sig "v7/sapling.mli"] + module Sapling : [%sig "v7/sapling.mli"] [@@coq_plain_module] - module Timelock : [%sig "v7/timelock.mli"] + module Timelock : [%sig "v7/timelock.mli"] [@@coq_plain_module] - module Vdf : [%sig "v7/vdf.mli"] + module Vdf : [%sig "v7/vdf.mli"] [@@coq_plain_module] - module Micheline : [%sig "v7/micheline.mli"] + module Micheline : [%sig "v7/micheline.mli"] [@@coq_plain_module] - module Block_header : [%sig "v7/block_header.mli"] + module Block_header : [%sig "v7/block_header.mli"] [@@coq_plain_module] - module Bounded : [%sig "v7/bounded.mli"] + module Bounded : [%sig "v7/bounded.mli"] [@@coq_plain_module] - module Fitness : [%sig "v7/fitness.mli"] + module Fitness : [%sig "v7/fitness.mli"] [@@coq_plain_module] - module Operation : [%sig "v7/operation.mli"] + module Operation : [%sig "v7/operation.mli"] [@@coq_plain_module] - module Context : [%sig "v7/context.mli"] + module Context : [%sig "v7/context.mli"] [@@coq_plain_module] - module Updater : [%sig "v7/updater.mli"] + module Updater : [%sig "v7/updater.mli"] [@@coq_plain_module] - module RPC_context : [%sig "v7/RPC_context.mli"] + module RPC_context : [%sig "v7/RPC_context.mli"] [@@coq_plain_module] - module Wasm_2_0_0 : [%sig "v7/wasm_2_0_0.mli"] + module Wasm_2_0_0 : [%sig "v7/wasm_2_0_0.mli"] [@@coq_plain_module] - module Plonk : [%sig "v7/plonk.mli"] + module Plonk : [%sig "v7/plonk.mli"] [@@coq_plain_module] - module Dal : [%sig "v7/dal.mli"] + module Dal : [%sig "v7/dal.mli"] [@@coq_plain_module] end diff --git a/src/lib_protocol_environment/sigs/v7.ml b/src/lib_protocol_environment/sigs/v7.ml index 23234d810470a..1bb3e5ad94044 100644 --- a/src/lib_protocol_environment/sigs/v7.ml +++ b/src/lib_protocol_environment/sigs/v7.ml @@ -492,7 +492,7 @@ val ( ^^ ) : *) end # 6 "v7.in.ml" - + [@@coq_plain_module] open Pervasives @@ -574,7 +574,7 @@ val compare : [Left _] values are smaller than [Right _] values. *) end # 10 "v7.in.ml" - + [@@coq_plain_module] module String : sig # 1 "v7/string.mli" @@ -822,7 +822,7 @@ val split_on_char: char -> string -> string list *) end # 12 "v7.in.ml" - + [@@coq_plain_module] module Char : sig # 1 "v7/char.mli" @@ -882,7 +882,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 14 "v7.in.ml" - + [@@coq_plain_module] module Bytes : sig # 1 "v7/bytes.mli" @@ -1146,7 +1146,7 @@ val equal: t -> t -> bool @since 4.03.0 (4.05.0 in BytesLabels) *) end # 16 "v7.in.ml" - + [@@coq_plain_module] module Int32 : sig # 1 "v7/int32.mli" @@ -1297,7 +1297,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 18 "v7.in.ml" - + [@@coq_plain_module] module Int64 : sig # 1 "v7/int64.mli" @@ -1456,7 +1456,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 20 "v7.in.ml" - + [@@coq_plain_module] module Format : sig # 1 "v7/format.mli" @@ -2220,7 +2220,7 @@ val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b *) end # 22 "v7.in.ml" - + [@@coq_plain_module] module Logging : sig # 1 "v7/logging.mli" @@ -2270,7 +2270,7 @@ val log : level -> ('a, Format.formatter, unit, unit) format4 -> 'a val log_string : level -> string -> unit end # 24 "v7.in.ml" - + [@@coq_plain_module] module Hex : sig # 1 "v7/hex.mli" @@ -2358,7 +2358,7 @@ val show : t -> string a string. *) end # 26 "v7.in.ml" - + [@@coq_plain_module] module Z : sig # 1 "v7/z.mli" @@ -2832,7 +2832,7 @@ external of_bits: string -> t = "ml_z_of_bits" *) end # 28 "v7.in.ml" - + [@@coq_plain_module] module Q : sig # 1 "v7/q.mli" @@ -3104,7 +3104,7 @@ val (<>): t -> t -> bool (** [a <> b] is equivalent to [not (equal a b)]. *) end # 30 "v7.in.ml" - + [@@coq_plain_module] module Lwt : sig # 1 "v7/lwt.mli" @@ -3416,7 +3416,7 @@ val return_error : 'e -> ((_, 'e) result) t @since Lwt 2.6.0 *) end # 32 "v7.in.ml" - + [@@coq_plain_module] module Data_encoding : sig # 1 "v7/data_encoding.mli" @@ -4893,7 +4893,7 @@ module Binary : sig end end # 34 "v7.in.ml" - + [@@coq_plain_module] module Raw_hashes : sig # 1 "v7/raw_hashes.mli" @@ -4935,7 +4935,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end # 36 "v7.in.ml" - + [@@coq_plain_module] module Compare : sig # 1 "v7/compare.mli" @@ -5061,6 +5061,7 @@ module Int : sig external equal : int -> int -> bool = "%equal" end +[@@coq_plain_module] module Int32 : S with type t = int32 @@ -5216,7 +5217,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = val or_else : int -> (unit -> int) -> int end # 38 "v7.in.ml" - + [@@coq_plain_module] module Time : sig # 1 "v7/time.mli" @@ -5270,7 +5271,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end # 40 "v7.in.ml" - + [@@coq_plain_module] module TzEndian : sig # 1 "v7/tzEndian.mli" @@ -5336,7 +5337,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end # 42 "v7.in.ml" - + [@@coq_plain_module] module Bits : sig # 1 "v7/bits.mli" @@ -5373,7 +5374,7 @@ end val numbits : int -> int end # 44 "v7.in.ml" - + [@@coq_plain_module] module Equality_witness : sig # 1 "v7/equality_witness.mli" @@ -5442,6 +5443,7 @@ val hash : 'a t -> int end # 46 "v7.in.ml" + [@@coq_plain_module] module FallbackArray : sig # 1 "v7/fallbackArray.mli" @@ -5530,8 +5532,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 -# 48 "v7.in.ml" - +# 49 "v7.in.ml" + [@@coq_plain_module] module Error_monad : sig # 1 "v7/error_monad.mli" @@ -6012,8 +6014,8 @@ module Lwt_tzresult_syntax : sig ('a * 'b, 'error trace) result Lwt.t end end -# 50 "v7.in.ml" - +# 51 "v7.in.ml" + [@@coq_plain_module] open Error_monad @@ -6139,8 +6141,8 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 54 "v7.in.ml" - +# 55 "v7.in.ml" + [@@coq_plain_module] module List : sig # 1 "v7/list.mli" @@ -7485,8 +7487,8 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 56 "v7.in.ml" - +# 57 "v7.in.ml" + [@@coq_plain_module] module Array : sig # 1 "v7/array.mli" @@ -7595,8 +7597,8 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 58 "v7.in.ml" - +# 59 "v7.in.ml" + [@@coq_plain_module] module Set : sig # 1 "v7/set.mli" @@ -7744,8 +7746,8 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 60 "v7.in.ml" - +# 61 "v7.in.ml" + [@@coq_plain_module] module Map : sig # 1 "v7/map.mli" @@ -7913,8 +7915,8 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 62 "v7.in.ml" - +# 63 "v7.in.ml" + [@@coq_plain_module] module Option : sig # 1 "v7/option.mli" @@ -8061,8 +8063,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 -# 64 "v7.in.ml" - +# 65 "v7.in.ml" + [@@coq_plain_module] module Result : sig # 1 "v7/result.mli" @@ -8227,8 +8229,8 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 66 "v7.in.ml" - +# 67 "v7.in.ml" + [@@coq_plain_module] module RPC_arg : sig # 1 "v7/RPC_arg.mli" @@ -8297,8 +8299,8 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 68 "v7.in.ml" - +# 69 "v7.in.ml" + [@@coq_plain_module] module RPC_path : sig # 1 "v7/RPC_path.mli" @@ -8353,8 +8355,8 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 70 "v7.in.ml" - +# 71 "v7.in.ml" + [@@coq_plain_module] module RPC_query : sig # 1 "v7/RPC_query.mli" @@ -8425,8 +8427,8 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 72 "v7.in.ml" - +# 73 "v7.in.ml" + [@@coq_plain_module] module RPC_service : sig # 1 "v7/RPC_service.mli" @@ -8502,8 +8504,8 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 74 "v7.in.ml" - +# 75 "v7.in.ml" + [@@coq_plain_module] module RPC_answer : sig # 1 "v7/RPC_answer.mli" @@ -8563,8 +8565,8 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 76 "v7.in.ml" - +# 77 "v7.in.ml" + [@@coq_plain_module] module RPC_directory : sig # 1 "v7/RPC_directory.mli" @@ -8833,8 +8835,8 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 78 "v7.in.ml" - +# 79 "v7.in.ml" + [@@coq_plain_module] module Base58 : sig # 1 "v7/base58.mli" @@ -8898,8 +8900,8 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 80 "v7.in.ml" - +# 81 "v7.in.ml" + [@@coq_plain_module] module S : sig # 1 "v7/s.mli" @@ -9260,8 +9262,8 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 82 "v7.in.ml" - +# 83 "v7.in.ml" + [@@coq_plain_module] module Blake2B : sig # 1 "v7/blake2B.mli" @@ -9325,8 +9327,8 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 84 "v7.in.ml" - +# 85 "v7.in.ml" + [@@coq_plain_module] module Bls : sig # 1 "v7/bls.mli" @@ -9371,8 +9373,8 @@ module Primitive : sig val pairing_check : (G1.t * G2.t) list -> bool end end -# 86 "v7.in.ml" - +# 87 "v7.in.ml" + [@@coq_plain_module] module Ed25519 : sig # 1 "v7/ed25519.mli" @@ -9405,8 +9407,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v7.in.ml" - +# 89 "v7.in.ml" + [@@coq_plain_module] module Secp256k1 : sig # 1 "v7/secp256k1.mli" @@ -9439,8 +9441,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v7.in.ml" - +# 91 "v7.in.ml" + [@@coq_plain_module] module P256 : sig # 1 "v7/p256.mli" @@ -9473,8 +9475,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v7.in.ml" - +# 93 "v7.in.ml" + [@@coq_plain_module] module Chain_id : sig # 1 "v7/chain_id.mli" @@ -9505,8 +9507,8 @@ end include S.HASH end -# 94 "v7.in.ml" - +# 95 "v7.in.ml" + [@@coq_plain_module] module Signature : sig # 1 "v7/signature.mli" @@ -9557,8 +9559,8 @@ include and type Public_key.t = public_key and type watermark := watermark end -# 96 "v7.in.ml" - +# 97 "v7.in.ml" + [@@coq_plain_module] module Block_hash : sig # 1 "v7/block_hash.mli" @@ -9590,8 +9592,8 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v7.in.ml" - +# 99 "v7.in.ml" + [@@coq_plain_module] module Operation_hash : sig # 1 "v7/operation_hash.mli" @@ -9623,8 +9625,8 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v7.in.ml" - +# 101 "v7.in.ml" + [@@coq_plain_module] module Operation_list_hash : sig # 1 "v7/operation_list_hash.mli" @@ -9656,8 +9658,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v7.in.ml" +# 103 "v7.in.ml" + [@@coq_plain_module] module Operation_list_list_hash : sig # 1 "v7/operation_list_list_hash.mli" @@ -9689,8 +9692,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v7.in.ml" +# 106 "v7.in.ml" + [@@coq_plain_module] module Protocol_hash : sig # 1 "v7/protocol_hash.mli" @@ -9722,8 +9726,8 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v7.in.ml" - +# 109 "v7.in.ml" + [@@coq_plain_module] module Context_hash : sig # 1 "v7/context_hash.mli" @@ -9775,8 +9779,8 @@ end type version = Version.t end -# 108 "v7.in.ml" - +# 111 "v7.in.ml" + [@@coq_plain_module] module Sapling : sig # 1 "v7/sapling.mli" @@ -9923,8 +9927,8 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v7.in.ml" - +# 113 "v7.in.ml" + [@@coq_plain_module] module Timelock : sig # 1 "v7/timelock.mli" @@ -9982,8 +9986,8 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v7.in.ml" - +# 115 "v7.in.ml" + [@@coq_plain_module] module Vdf : sig # 1 "v7/vdf.mli" @@ -10070,8 +10074,8 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 114 "v7.in.ml" - +# 117 "v7.in.ml" + [@@coq_plain_module] module Micheline : sig # 1 "v7/micheline.mli" @@ -10130,8 +10134,8 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 116 "v7.in.ml" - +# 119 "v7.in.ml" + [@@coq_plain_module] module Block_header : sig # 1 "v7/block_header.mli" @@ -10187,8 +10191,8 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 118 "v7.in.ml" - +# 121 "v7.in.ml" + [@@coq_plain_module] module Bounded : sig # 1 "v7/bounded.mli" @@ -10336,8 +10340,8 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 120 "v7.in.ml" - +# 123 "v7.in.ml" + [@@coq_plain_module] module Fitness : sig # 1 "v7/fitness.mli" @@ -10370,8 +10374,8 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 122 "v7.in.ml" - +# 125 "v7.in.ml" + [@@coq_plain_module] module Operation : sig # 1 "v7/operation.mli" @@ -10414,8 +10418,8 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 124 "v7.in.ml" - +# 127 "v7.in.ml" + [@@coq_plain_module] module Context : sig # 1 "v7/context.mli" @@ -11051,8 +11055,8 @@ module Cache : and type key = cache_key and type value = cache_value end -# 126 "v7.in.ml" - +# 129 "v7.in.ml" + [@@coq_plain_module] module Updater : sig # 1 "v7/updater.mli" @@ -11446,6 +11450,8 @@ module type PROTOCOL = sig mempool. *) type validation_info + type keep_or_replace = Keep | Replace + (** Type of the function that may be provided in order to resolve a potential conflict when adding an operation to an existing mempool or when merging two mempools. This handler may be defined as a @@ -11459,7 +11465,7 @@ module type PROTOCOL = sig type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { @@ -11576,8 +11582,8 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 128 "v7.in.ml" - +# 131 "v7.in.ml" + [@@coq_plain_module] module RPC_context : sig # 1 "v7/RPC_context.mli" @@ -11731,8 +11737,8 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 130 "v7.in.ml" - +# 133 "v7.in.ml" + [@@coq_plain_module] module Wasm_2_0_0 : sig # 1 "v7/wasm_2_0_0.mli" @@ -11773,19 +11779,24 @@ type info = { input_request : input_request; } -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val compute_step : Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree - val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t + val compute_step : tree -> tree Lwt.t - val get_output : output -> Tree.tree -> string Lwt.t + val set_input_step : input -> string -> tree -> tree Lwt.t - val get_info : Tree.tree -> info Lwt.t -end + val get_output : output -> tree -> string Lwt.t + + val get_info : tree -> info Lwt.t end -# 132 "v7.in.ml" +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree +end +# 135 "v7.in.ml" + [@@coq_plain_module] module Plonk : sig # 1 "v7/plonk.mli" @@ -11852,8 +11863,8 @@ val verify_multi_circuits : proof -> bool end -# 134 "v7.in.ml" - +# 137 "v7.in.ml" + [@@coq_plain_module] module Dal : sig # 1 "v7/dal.mli" @@ -11960,6 +11971,6 @@ val verify_page : [> `Degree_exceeds_srs_length of string | `Segment_index_out_of_range] ) Result.t end -# 136 "v7.in.ml" - +# 139 "v7.in.ml" + [@@coq_plain_module] end diff --git a/src/lib_protocol_environment/sigs/v7/compare.mli b/src/lib_protocol_environment/sigs/v7/compare.mli index 22e295139c479..70dbae5d347c3 100644 --- a/src/lib_protocol_environment/sigs/v7/compare.mli +++ b/src/lib_protocol_environment/sigs/v7/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/v7/updater.mli b/src/lib_protocol_environment/sigs/v7/updater.mli index d68ad345b025a..11a8da1a6811d 100644 --- a/src/lib_protocol_environment/sigs/v7/updater.mli +++ b/src/lib_protocol_environment/sigs/v7/updater.mli @@ -388,6 +388,8 @@ module type PROTOCOL = sig mempool. *) type validation_info + type keep_or_replace = Keep | Replace + (** Type of the function that may be provided in order to resolve a potential conflict when adding an operation to an existing mempool or when merging two mempools. This handler may be defined as a @@ -401,7 +403,7 @@ module type PROTOCOL = sig type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli index aa17a2bb4f6ae..44da10bd768fe 100644 --- a/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli @@ -35,13 +35,18 @@ type info = { input_request : input_request; } -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val compute_step : Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree + + val compute_step : tree -> tree Lwt.t - val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t + val set_input_step : input -> string -> tree -> tree Lwt.t - val get_output : output -> Tree.tree -> string Lwt.t + val get_output : output -> tree -> string Lwt.t - val get_info : Tree.tree -> info Lwt.t + val get_info : tree -> info Lwt.t end + +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree diff --git a/src/lib_protocol_environment/sigs/v8.ml b/src/lib_protocol_environment/sigs/v8.ml index 7c2669649a3c0..b1f5fe4171ef2 100644 --- a/src/lib_protocol_environment/sigs/v8.ml +++ b/src/lib_protocol_environment/sigs/v8.ml @@ -11754,6 +11754,8 @@ module type PROTOCOL = sig mempool. *) type validation_info + type keep_or_replace = Keep | Replace + (** Type of the function that may be provided in order to resolve a potential conflict when adding an operation to an existing mempool or when merging two mempools. This handler may be defined as a @@ -11767,7 +11769,7 @@ module type PROTOCOL = sig type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { @@ -12090,20 +12092,25 @@ type info = { input_request : input_request; } -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val install_boot_sector : string -> Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree - val compute_step : Tree.tree -> Tree.tree Lwt.t + val install_boot_sector : string -> tree -> tree Lwt.t - val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t + val compute_step : tree -> tree Lwt.t - val reveal_step : bytes -> Tree.tree -> Tree.tree Lwt.t + val set_input_step : input -> string -> tree -> tree Lwt.t - val get_output : output -> Tree.tree -> string option Lwt.t + val reveal_step : bytes -> tree -> tree Lwt.t - val get_info : Tree.tree -> info Lwt.t + val get_output : output -> tree -> string option Lwt.t + + val get_info : tree -> info Lwt.t end + +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree end # 132 "v8.in.ml" diff --git a/src/lib_protocol_environment/sigs/v8/updater.mli b/src/lib_protocol_environment/sigs/v8/updater.mli index d68ad345b025a..11a8da1a6811d 100644 --- a/src/lib_protocol_environment/sigs/v8/updater.mli +++ b/src/lib_protocol_environment/sigs/v8/updater.mli @@ -388,6 +388,8 @@ module type PROTOCOL = sig mempool. *) type validation_info + type keep_or_replace = Keep | Replace + (** Type of the function that may be provided in order to resolve a potential conflict when adding an operation to an existing mempool or when merging two mempools. This handler may be defined as a @@ -401,7 +403,7 @@ module type PROTOCOL = sig type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/lib_protocol_environment/sigs/v8/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v8/wasm_2_0_0.mli index 1a7dfd7ef23ed..055b82607a8a1 100644 --- a/src/lib_protocol_environment/sigs/v8/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v8/wasm_2_0_0.mli @@ -44,17 +44,22 @@ type info = { input_request : input_request; } -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val install_boot_sector : string -> Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree + + val install_boot_sector : string -> tree -> tree Lwt.t - val compute_step : Tree.tree -> Tree.tree Lwt.t + val compute_step : tree -> tree Lwt.t - val set_input_step : input -> string -> Tree.tree -> Tree.tree Lwt.t + val set_input_step : input -> string -> tree -> tree Lwt.t - val reveal_step : bytes -> Tree.tree -> Tree.tree Lwt.t + val reveal_step : bytes -> tree -> tree Lwt.t - val get_output : output -> Tree.tree -> string option Lwt.t + val get_output : output -> tree -> string option Lwt.t - val get_info : Tree.tree -> info Lwt.t + val get_info : tree -> info Lwt.t end + +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree diff --git a/src/proto_013_PtJakart/lib_injector/injector_functor.ml b/src/proto_013_PtJakart/lib_injector/injector_functor.ml index e5244531d41cc..3c8b84893872b 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 3cc674bbcd371..03b0bc99c9f96 100644 --- a/src/proto_013_PtJakart/lib_plugin/plugin.ml +++ b/src/proto_013_PtJakart/lib_plugin/plugin.ml @@ -1608,7 +1608,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 = @@ -1618,7 +1618,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) @@ -1633,7 +1634,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 = @@ -1646,7 +1647,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 = @@ -1659,7 +1660,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 = @@ -2339,8 +2340,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..97c3f9809d1fb 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 @@ -1099,7 +1273,7 @@ and 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 @@ -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/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 () () 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 784a4f38989f9..75892ba095623 100644 --- a/src/proto_014_PtKathma/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_014_PtKathma/lib_delegate/client_baking_denunciation.ml @@ -115,7 +115,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) @@ -124,7 +124,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:Tezos_crypto.Block_hash.t -> @@ -136,7 +136,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 e5244531d41cc..3c8b84893872b 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 ef87cdc107703..9bad8cc7a2312 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..097c507d19963 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 @@ -366,7 +365,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 @@ -416,7 +420,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_014_PtKathma/lib_protocol/alpha_context.mli b/src/proto_014_PtKathma/lib_protocol/alpha_context.mli index 6cb97c19b8488..3a84080a796a0 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 = @@ -3479,72 +3496,72 @@ module Kind : sig type double_preendorsement_evidence = preendorsement_consensus_kind double_consensus_operation_evidence - type double_baking_evidence = Double_baking_evidence_kind + type double_baking_evidence = Operation_repr.Kind.double_baking_evidence = Double_baking_evidence_kind - type activate_account = Activate_account_kind + type activate_account = Operation_repr.Kind.activate_account = Activate_account_kind - type proposals = Proposals_kind + type proposals = Operation_repr.Kind.proposals = Proposals_kind - type ballot = Ballot_kind + type ballot = Operation_repr.Kind.ballot = Ballot_kind - type reveal = Reveal_kind + type reveal = Operation_repr.Kind.reveal = Reveal_kind - type transaction = Transaction_kind + type transaction = Operation_repr.Kind.transaction = Transaction_kind - type origination = Origination_kind + type origination = Operation_repr.Kind.origination = Origination_kind - type delegation = Delegation_kind + type delegation = Operation_repr.Kind.delegation = Delegation_kind - type event = Event_kind + type event = Operation_repr.Kind.event = Event_kind - type set_deposits_limit = Set_deposits_limit_kind + type set_deposits_limit = Operation_repr.Kind.set_deposits_limit = Set_deposits_limit_kind - type increase_paid_storage = Increase_paid_storage_kind + type increase_paid_storage = Operation_repr.Kind.increase_paid_storage = Increase_paid_storage_kind - type failing_noop = Failing_noop_kind + type failing_noop = Operation_repr.Kind.failing_noop = Failing_noop_kind - type register_global_constant = Register_global_constant_kind + type register_global_constant = Operation_repr.Kind.register_global_constant = Register_global_constant_kind - type tx_rollup_origination = Tx_rollup_origination_kind + type tx_rollup_origination = Operation_repr.Kind.tx_rollup_origination = Tx_rollup_origination_kind - type tx_rollup_submit_batch = Tx_rollup_submit_batch_kind + type tx_rollup_submit_batch = Operation_repr.Kind.tx_rollup_submit_batch = Tx_rollup_submit_batch_kind - type tx_rollup_commit = Tx_rollup_commit_kind + type tx_rollup_commit = Operation_repr.Kind.tx_rollup_commit = Tx_rollup_commit_kind - type tx_rollup_return_bond = Tx_rollup_return_bond_kind + type tx_rollup_return_bond = Operation_repr.Kind.tx_rollup_return_bond = Tx_rollup_return_bond_kind - type tx_rollup_finalize_commitment = Tx_rollup_finalize_commitment_kind + type tx_rollup_finalize_commitment = Operation_repr.Kind.tx_rollup_finalize_commitment = Tx_rollup_finalize_commitment_kind - type tx_rollup_remove_commitment = Tx_rollup_remove_commitment_kind + type tx_rollup_remove_commitment = Operation_repr.Kind.tx_rollup_remove_commitment = Tx_rollup_remove_commitment_kind - type tx_rollup_rejection = Tx_rollup_rejection_kind + type tx_rollup_rejection = Operation_repr.Kind.tx_rollup_rejection = Tx_rollup_rejection_kind - type tx_rollup_dispatch_tickets = Tx_rollup_dispatch_tickets_kind + type tx_rollup_dispatch_tickets = Operation_repr.Kind.tx_rollup_dispatch_tickets = Tx_rollup_dispatch_tickets_kind - type transfer_ticket = Transfer_ticket_kind + type transfer_ticket = Operation_repr.Kind.transfer_ticket = Transfer_ticket_kind - type dal_publish_slot_header = Dal_publish_slot_header_kind + type dal_publish_slot_header = Operation_repr.Kind.dal_publish_slot_header = Dal_publish_slot_header_kind - type sc_rollup_originate = Sc_rollup_originate_kind + type sc_rollup_originate = Operation_repr.Kind.sc_rollup_originate = Sc_rollup_originate_kind - type sc_rollup_add_messages = Sc_rollup_add_messages_kind + type sc_rollup_add_messages = Operation_repr.Kind.sc_rollup_add_messages = Sc_rollup_add_messages_kind - type sc_rollup_cement = Sc_rollup_cement_kind + type sc_rollup_cement = Operation_repr.Kind.sc_rollup_cement = Sc_rollup_cement_kind - type sc_rollup_publish = Sc_rollup_publish_kind + type sc_rollup_publish = Operation_repr.Kind.sc_rollup_publish = Sc_rollup_publish_kind - type sc_rollup_refute = Sc_rollup_refute_kind + type sc_rollup_refute = Operation_repr.Kind.sc_rollup_refute = Sc_rollup_refute_kind - type sc_rollup_timeout = Sc_rollup_timeout_kind + type sc_rollup_timeout = Operation_repr.Kind.sc_rollup_timeout = Sc_rollup_timeout_kind - type sc_rollup_execute_outbox_message = + type sc_rollup_execute_outbox_message = Operation_repr.Kind.sc_rollup_execute_outbox_message = | Sc_rollup_execute_outbox_message_kind - type sc_rollup_recover_bond = Sc_rollup_recover_bond_kind + type sc_rollup_recover_bond = Operation_repr.Kind.sc_rollup_recover_bond = Sc_rollup_recover_bond_kind - type sc_rollup_dal_slot_subscribe = Sc_rollup_dal_slot_subscribe_kind + type sc_rollup_dal_slot_subscribe = Operation_repr.Kind.sc_rollup_dal_slot_subscribe = Sc_rollup_dal_slot_subscribe_kind - type 'a manager = + type 'a manager = 'a Operation_repr.Kind.manager = | Reveal_manager_kind : reveal manager | Transaction_manager_kind : transaction manager | Origination_manager_kind : origination manager @@ -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..e884663c909c2 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) -> @@ -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) @@ -1866,7 +1886,7 @@ let apply_external_manager_operation_content : inclusion_proof; message; } -> - Sc_rollup_operations.execute_outbox_message + (Sc_rollup_operations.execute_outbox_message[@coq_type_annotation]) ctxt rollup cemented_commitment @@ -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 @@ -2302,14 +2322,15 @@ let take_fees ctxt (_ : Validate_operation.stamp) contents_list = (context * kind Kind.manager fees_updated_contents_list) tzresult Lwt.t = fun ctxt contents_list -> let contents_effects contents = - let (Manager_operation {source; fee; gas_limit; _}) = contents in + let[@coq_match_with_default] + (Manager_operation {source; fee; gas_limit; _}) = contents in let*? ctxt = Gas.consume_limit_in_block ctxt gas_limit in let* ctxt = Contract.increment_counter ctxt source in 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}) @@ -2394,7 +2415,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 +2468,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 +2493,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 +2598,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 +2624,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 +2651,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 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 +2736,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 +2755,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 +2772,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 +2816,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 +2859,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 +2880,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 +2988,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 +3024,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 +3157,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_internal_results.ml b/src/proto_014_PtKathma/lib_protocol/apply_internal_results.ml index 1e6758d9e5733..fa7b0e0698f6f 100644 --- a/src/proto_014_PtKathma/lib_protocol/apply_internal_results.ml +++ b/src/proto_014_PtKathma/lib_protocol/apply_internal_results.ml @@ -209,7 +209,7 @@ module Internal_result = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = + let transaction_contract_variant_cases = union [ case @@ -313,7 +313,7 @@ module Internal_result = struct Transaction_to_sc_rollup_result {consumed_gas; inbox_after}); ] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = MCase { (* This value should be changed with care: maybe receipts are read by @@ -338,7 +338,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 @@ -358,7 +358,7 @@ module Internal_result = struct Transaction {amount; destination; parameters; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = MCase { (* This value should be changed with care: maybe receipts are read by @@ -379,14 +379,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 { (* This value should be changed with care: maybe receipts are read by @@ -402,11 +402,11 @@ 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); } - let[@coq_axiom_with_reason "gadt"] event_case = + let event_case = MCase { (* This value should be changed with care: maybe receipts are read by @@ -426,7 +426,7 @@ module Internal_result = struct | _ -> None); select = (function Manager (Event _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Event {ty; tag; payload} -> let tag = if Entrypoint.is_default tag then None else Some tag in let payload = @@ -449,7 +449,9 @@ module Internal_result = struct (fun ((), x) -> inj x) let encoding = - let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) = + let make mcase = + match[@coq_match_gadt] mcase with + | MCase {tag; name; encoding; iselect = _; select; proj; inj} -> case (Tag tag) name @@ -505,7 +507,7 @@ module Internal_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_internal_manager_result o) with @@ -535,7 +537,7 @@ module Internal_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_internal_manager_result o) with @@ -546,7 +548,7 @@ module Internal_manager_result = struct in MCase {op_case; encoding; kind; select; proj; inj; t} - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make ~op_case:Internal_result.transaction_case ~encoding:Internal_result.transaction_contract_variant_cases @@ -555,10 +557,10 @@ module Internal_manager_result = struct Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function ITransaction_result x -> x) + ~proj:(function[@coq_match_with_default] ITransaction_result x -> x) ~inj:(fun x -> ITransaction_result x) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make ~op_case:Internal_result.origination_case ~encoding: @@ -573,7 +575,7 @@ module Internal_manager_result = struct | Successful_internal_manager_result (IOrigination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | IOrigination_result { lazy_storage_diff; @@ -647,7 +649,9 @@ let internal_manager_operation_result_encoding : let make (type kind) (Internal_manager_result.MCase res_case : kind Internal_manager_result.case) - (Internal_result.MCase ires_case : kind Internal_result.case) = + (ires_mcase : kind Internal_result.case) = + match[@coq_match_gadt] ires_mcase with + | Internal_result.MCase ires_case -> let (Internal_result.MCase op_case) = res_case.op_case in case (Tag op_case.tag) diff --git a/src/proto_014_PtKathma/lib_protocol/apply_operation_result.ml b/src/proto_014_PtKathma/lib_protocol/apply_operation_result.ml index d82aec0e522a5..2a57cf4781f3d 100644 --- a/src/proto_014_PtKathma/lib_protocol/apply_operation_result.ml +++ b/src/proto_014_PtKathma/lib_protocol/apply_operation_result.ml @@ -25,14 +25,13 @@ open Data_encoding -type ('kind, 'manager, 'successful) operation_result = +type (_, 'manager, 'successful) operation_result = | Applied of 'successful | Backtracked of 'successful * error trace option | Failed : 'manager * error trace -> ('kind, 'manager, 'successful) operation_result | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result -[@@coq_force_gadt] let error_encoding = def diff --git a/src/proto_014_PtKathma/lib_protocol/apply_operation_result.mli b/src/proto_014_PtKathma/lib_protocol/apply_operation_result.mli index 11704df359d9f..914666661d867 100644 --- a/src/proto_014_PtKathma/lib_protocol/apply_operation_result.mli +++ b/src/proto_014_PtKathma/lib_protocol/apply_operation_result.mli @@ -32,13 +32,12 @@ The ['kind] parameter is used to make the type a GADT, but ['manager] and ['successful] are used to share [operation_result] between internal and external operation results, and are instantiated for each case. *) -type ('kind, 'manager, 'successful) operation_result = +type (_, 'manager, 'successful) operation_result = | Applied of 'successful | Backtracked of 'successful * error trace option | Failed : 'manager * error trace -> ('kind, 'manager, 'successful) operation_result | Skipped : 'manager -> ('kind, 'manager, 'successful) operation_result -[@@coq_force_gadt] val trace_encoding : error trace Data_encoding.t diff --git a/src/proto_014_PtKathma/lib_protocol/apply_results.ml b/src/proto_014_PtKathma/lib_protocol/apply_results.ml index d8d4b8276a2a5..3883568d213dd 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 @@ -1702,7 +1720,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_dal_slot_subscribe_case = + let sc_rollup_dal_slot_subscribe_case = make_manager_case Operation.Encoding.sc_rollup_dal_slot_subscribe_case Manager_result.sc_rollup_dal_slot_subscribe_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} @@ -1939,7 +1977,7 @@ let 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/contract_services.ml b/src/proto_014_PtKathma/lib_protocol/contract_services.ml index 1d18c7117acf7..3bc94e284f880 100644 --- a/src/proto_014_PtKathma/lib_protocol/contract_services.ml +++ b/src/proto_014_PtKathma/lib_protocol/contract_services.ml @@ -290,7 +290,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_gen ~filter_contract ~wrap_result ~chunked s f = @@ -342,7 +342,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 @@ -354,7 +354,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 = @@ -365,7 +365,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 -> @@ -377,7 +377,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, [])) @@ -439,8 +439,9 @@ 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}, - _ ) -> + >>? 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 ()) @@ -455,7 +456,7 @@ let[@coq_axiom_with_reason "gadt"] register () = Some (Micheline.strip_locations ty_node) else ok (Some (Micheline.strip_locations original_type_expr)) - | Error _ -> Result.return_none ))) ; + | Error _ -> Result.return_none) ))) ; opt_register1 ~chunked:true S.list_entrypoints diff --git a/src/proto_014_PtKathma/lib_protocol/contract_storage.ml b/src/proto_014_PtKathma/lib_protocol/contract_storage.ml index 6a8ea9cf2c7aa..d986c55e10bb6 100644 --- a/src/proto_014_PtKathma/lib_protocol/contract_storage.ml +++ b/src/proto_014_PtKathma/lib_protocol/contract_storage.ml @@ -355,16 +355,18 @@ 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)) -> + (fun legacy_diffs arg -> + match[@coq_match_gadt_with_result] arg with + | Lazy_storage_diff.Item (kind, id, diff) -> let diffs = - match kind with + 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 + ((id [@coq_cast]) : Storage.Big_map.id) in - match diff with + match[@coq_match_gadt] diff with | Remove -> [Clear id] | Update {init; updates} -> ( let updates = @@ -377,7 +379,8 @@ module Legacy_big_map_diff = struct diff_key_hash = key_hash; diff_value = value; }) - updates + ((updates [@coq_cast]) + : Lazy_storage_kind.Big_map.update list) in match init with | Existing -> updates @@ -385,18 +388,23 @@ module Legacy_big_map_diff = struct let src = Lazy_storage_kind.Big_map.Id .to_legacy_USE_ONLY_IN_Legacy_big_map_diff - src + ((src [@coq_cast]) : Storage.Big_map.id) in Copy {src; dst = id} :: updates - | Alloc {key_type; value_type} -> - Alloc {big_map = id; key_type; value_type} :: 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_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..80fa266f4b6a5 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,37 +105,37 @@ 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_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) -> + match[@coq_match_gadt][@coq_match_with_default] wit, v with + | Never_t, _ -> . + | Unit_t, _ -> unit + | Int_t, (v : _ Script_int.num) -> integer v + | Nat_t, (v : _ Script_int.num) -> integer v + | String_t, (v : Script_string.t) -> script_string v + | Bytes_t, (v : bytes) -> bytes v + | Mutez_t, (v : Tez_repr.t) -> mutez v + | Bool_t, (v : bool) -> bool v + | Key_hash_t, (v : Signature.public_key_hash) -> key_hash v + | Timestamp_t, (v : Script_timestamp.t) -> timestamp v + | Address_t, (v : Script_typed_ir.address) -> address v + | Tx_rollup_l2_address_t, (v : Script_typed_ir.tx_rollup_l2_address) -> tx_rollup_l2_address v + | Pair_t (leaf, node, _, YesYes), (v : _ * _) -> let lv, rv = v 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), (v : _ Script_typed_ir.union) -> let size = match v with | L v -> size_of_comparable_value left v | R v -> size_of_comparable_value right v in size + 1 - | Option_t (ty, _, Yes) -> ( + | Option_t (ty, _, Yes), (v : _ option) -> ( 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 + | Signature_t, (v : Script_typed_ir.signature) -> signature v + | Key_t, (v : Signature.public_key) -> public_key v + | Chain_id_t, (v : Script_typed_ir.Script_chain_id.t) -> chain_id v 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..bdeddc00a3cf8 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 @@ -80,16 +80,16 @@ let run ctxt m = | None -> error Gas.Operation_quota_exceeded) let record_trace_eval : - type error_trace error_context. + type a error_trace error_context. error_details:(error_context, error_trace) Script_tc_errors.error_details -> (error_context -> error) -> - ('a, error_trace) t -> - ('a, error_trace) t = - fun ~error_details -> - match error_details with - | Fast -> fun _f m -> m - | Informative err_ctxt -> - 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 err_ctxt, (m : (_, error trace) t) -> + fun gas -> m gas >>?? fun (x, gas) -> of_result (record_trace_eval (fun () -> f err_ctxt) x) gas 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..7c86781742054 100644 --- a/src/proto_014_PtKathma/lib_protocol/global_constants_storage.ml +++ b/src/proto_014_PtKathma/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_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/lazy_storage_diff.ml b/src/proto_014_PtKathma/lib_protocol/lazy_storage_diff.ml index a6126aabfe946..2edaa2e934af2 100644 --- a/src/proto_014_PtKathma/lib_protocol/lazy_storage_diff.ml +++ b/src/proto_014_PtKathma/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 @@ -413,26 +413,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_014_PtKathma/lib_protocol/lazy_storage_kind.ml b/src/proto_014_PtKathma/lib_protocol/lazy_storage_kind.ml index 59014e1547841..7cf60cea81874 100644 --- a/src/proto_014_PtKathma/lib_protocol/lazy_storage_kind.ml +++ b/src/proto_014_PtKathma/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_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..8909551aeb1e2 100644 --- a/src/proto_014_PtKathma/lib_protocol/misc.ml +++ b/src/proto_014_PtKathma/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_014_PtKathma/lib_protocol/operation_repr.ml b/src/proto_014_PtKathma/lib_protocol/operation_repr.ml index 9ee55663a0667..08631bed43220 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,18 +623,18 @@ 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[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = MCase { tag = 1; @@ -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 @@ -665,7 +671,7 @@ module Encoding = struct Transaction {amount; destination; parameters; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = MCase { tag = 2; @@ -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 = @@ -686,7 +692,7 @@ module Encoding = struct Origination {credit; delegate; script}); } - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = MCase { tag = 3; @@ -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,7 +1047,7 @@ 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; @@ -1042,11 +1056,11 @@ module Encoding = struct select = (function | Manager (Dal_publish_slot_header _ as op) -> Some op | _ -> None); - proj = (function Dal_publish_slot_header {slot} -> slot); + proj = (function[@coq_match_with_default] 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,13 +1112,13 @@ 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}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_refute_case = + let sc_rollup_refute_case = MCase { tag = sc_rollup_operation_refute_tag; @@ -1119,7 +1133,7 @@ module Encoding = struct (function | Manager (Sc_rollup_refute _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_refute {rollup; opponent; refutation; is_opening_move} -> (rollup, opponent, refutation, is_opening_move)); @@ -1128,7 +1142,7 @@ module Encoding = struct Sc_rollup_refute {rollup; opponent; refutation; is_opening_move}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_timeout_case = + let sc_rollup_timeout_case = MCase { tag = sc_rollup_operation_timeout_tag; @@ -1141,12 +1155,12 @@ module Encoding = struct (function | Manager (Sc_rollup_timeout _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_timeout {rollup; stakers} -> (rollup, stakers)); inj = (fun (rollup, stakers) -> Sc_rollup_timeout {rollup; stakers}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_execute_outbox_message_case = + let sc_rollup_execute_outbox_message_case = MCase { tag = sc_rollup_execute_outbox_message_tag; @@ -1166,7 +1180,7 @@ module Encoding = struct | Manager (Sc_rollup_execute_outbox_message _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_execute_outbox_message { rollup; @@ -1200,7 +1214,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_recover_bond_case = + let sc_rollup_recover_bond_case = MCase { tag = sc_rollup_operation_recover_bond_tag; @@ -1209,11 +1223,11 @@ module Encoding = struct select = (function | Manager (Sc_rollup_recover_bond _ as op) -> Some op | _ -> None); - proj = (function Sc_rollup_recover_bond {sc_rollup} -> sc_rollup); + proj = (function[@coq_match_with_default] Sc_rollup_recover_bond {sc_rollup} -> sc_rollup); inj = (fun sc_rollup -> Sc_rollup_recover_bond {sc_rollup}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_dal_slot_subscribe_case = + let sc_rollup_dal_slot_subscribe_case = MCase { tag = sc_rollup_operation_dal_slot_subscribe_tag; @@ -1227,7 +1241,7 @@ module Encoding = struct | Manager (Sc_rollup_dal_slot_subscribe _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_dal_slot_subscribe {rollup; slot_index} -> (rollup, slot_index)); inj = @@ -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 @@ -1356,7 +1379,7 @@ module Encoding = struct Dal_slot_availability (endorser, endorsement)); } - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { tag = 1; @@ -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..ed0a410d423fd 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} @@ -1526,7 +1596,7 @@ module Dal = struct the consensus which is hackish and probably not what we want at the end. However, it should be enough for a prototype. This has a very bad complexity too. *) - let rec compute_shards ?(index = 0) ctxt ~endorser = + let[@coq_struct "op_staroptstar"] rec compute_shards ?(index = 0) ctxt ~endorser = let max_shards = ctxt.back.constants.dal.number_of_shards in Slot_repr.Map.fold_e (fun _ (_, public_key_hash, power) (index, shards) -> 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..80de278ebcecc 100644 --- a/src/proto_014_PtKathma/lib_protocol/sc_rollup_errors.ml +++ b/src/proto_014_PtKathma/lib_protocol/sc_rollup_errors.ml @@ -24,6 +24,11 @@ (* *) (*****************************************************************************) +type sc_rollup_staker_in_game_error = + | Refuter of Signature.public_key_hash + | Defender of Signature.public_key_hash + | Both of Signature.public_key_hash * Signature.public_key_hash + type error += | (* `Temporary *) Sc_rollup_disputed | (* `Temporary *) Sc_rollup_does_not_exist of Sc_rollup_repr.t @@ -45,10 +50,7 @@ type error += | (* `Temporary *) Sc_rollup_wrong_turn | (* `Temporary *) Sc_rollup_no_game | (* `Temporary *) - Sc_rollup_staker_in_game of - [ `Refuter of Signature.public_key_hash - | `Defender of Signature.public_key_hash - | `Both of Signature.public_key_hash * Signature.public_key_hash ] + Sc_rollup_staker_in_game of sc_rollup_staker_in_game_error | (* `Temporary *) Sc_rollup_timeout_level_not_reached | (* `Temporary *) Sc_rollup_max_number_of_messages_reached_for_commitment_period @@ -89,19 +91,19 @@ let () = ~description:"Attempted to start a game where one staker is already busy" ~pp:(fun ppf staker -> let busy ppf = function - | `Refuter sc -> + | Refuter sc -> Format.fprintf ppf "the refuter (%a) is" Signature.Public_key_hash.pp sc - | `Defender sc -> + | Defender sc -> Format.fprintf ppf "the defender (%a) is" Signature.Public_key_hash.pp sc - | `Both (refuter, defender) -> + | Both (refuter, defender) -> Format.fprintf ppf "both the refuter (%a) and the defender (%a) are" @@ -122,14 +124,14 @@ let () = (Tag 0) ~title:"Refuter" (obj1 (req "refuter" Signature.Public_key_hash.encoding)) - (function `Refuter sc -> Some sc | _ -> None) - (fun sc -> `Refuter sc); + (function Refuter sc -> Some sc | _ -> None) + (fun sc -> Refuter sc); case (Tag 1) ~title:"Defender" (obj1 (req "defender" Signature.Public_key_hash.encoding)) - (function `Defender sc -> Some sc | _ -> None) - (fun sc -> `Defender sc); + (function Defender sc -> Some sc | _ -> None) + (fun sc -> Defender sc); case (Tag 2) ~title:"Both" @@ -137,9 +139,9 @@ let () = (req "refuter" Signature.Public_key_hash.encoding) (req "defender" Signature.Public_key_hash.encoding)) (function - | `Both (refuter, defender) -> Some (refuter, defender) + | Both (refuter, defender) -> Some (refuter, defender) | _ -> None) - (fun (refuter, defender) -> `Both (refuter, defender)); + (fun (refuter, defender) -> Both (refuter, defender)); ]) (function Sc_rollup_staker_in_game x -> Some x | _ -> None) (fun x -> Sc_rollup_staker_in_game x) ; 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..84d3f39c240ce 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 add_external_messages + history inbox level payloads messages = let open Lwt_tzresult_syntax in let*? payloads = List.map_e @@ -663,16 +666,19 @@ module MakeHashingScheme (Tree : TREE) : Sc_rollup_inbox_message_repr.(to_bytes @@ External payload)) payloads in - let* messages, With_history history, inbox = + let* messages, history, inbox = add_messages_aux (With_history history) inbox level payloads messages in + let[@coq_match_with_default] With_history history = history in return (messages, history, inbox) - let add_messages_no_history inbox level payloads messages = + let add_messages_no_history + inbox level payloads messages = let open Lwt_tzresult_syntax in - let* messages, No_history, inbox = + let* messages, history, inbox = add_messages_aux No_history inbox level payloads messages in + let[@coq_match_with_default] No_history = history in return (messages, inbox) (* An [inclusion_proof] is a path in the Merkelized skip list @@ -701,10 +707,11 @@ module MakeHashingScheme (Tree : TREE) : in aux [] ptr_path - let produce_inclusion_proof history inbox1 inbox2 = + let 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) = + let[@coq_match_with_default] (With_history history) = remember cell_ptr inbox2.old_levels_messages (With_history history) in let deref ptr = Hash.Map.find_opt ptr history.events in @@ -732,7 +739,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 +756,8 @@ include ( type value = bytes type key = string list + + let __infer_t (_ : t) = () end) : MerkelizedOperations with type tree = Context.tree) @@ -822,7 +839,7 @@ module Proof = struct let* r = get_message_payload tree n in return (tree, r) - let check_hash hash kinded_hash = + let check_hash hash (kinded_hash : Context.Proof.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 +855,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_struct "function_parameter"] rec valid + {inbox_level = l; message_counter = n} (inbox : 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..17862dff1315a 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 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 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 @@ -137,10 +139,10 @@ let produce pvm_and_state inbox commit_level = in let input_given = Option.bind input_given (cut_at_level commit_level) in let* pvm_step_proof = P.produce_proof P.context input_given P.state in - let module P_with_proof = struct + let module P_with_proof : Sc_rollups.PVM_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..7d2b45b1afb8f 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 = @@ -194,11 +194,11 @@ let init_game ctxt rollup ~refuter ~defender = match (opp_1, opp_2) with | None, None -> return () | Some _refuter_opponent, None -> - fail (Sc_rollup_staker_in_game (`Refuter refuter)) + fail (Sc_rollup_staker_in_game (Refuter refuter)) | None, Some _defender_opponent -> - fail (Sc_rollup_staker_in_game (`Defender defender)) + fail (Sc_rollup_staker_in_game (Defender defender)) | Some _refuter_opponent, Some _defender_opponent -> - fail (Sc_rollup_staker_in_game (`Both (refuter, defender))) + fail (Sc_rollup_staker_in_game (Both (refuter, defender))) in let* ( ( {hash = _refuter_commit; commitment = _info}, {hash = _defender_commit; commitment = child_info} ), 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..bd1a63f60926b 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 @@ -202,15 +203,15 @@ module V2_0_0 = struct let* s, _ = run m state in return s - let get_tick : Sc_rollup_tick_repr.t Monad.t = + let get_tick_aux : Sc_rollup_tick_repr.t Monad.t = let open Monad.Syntax in let* s = get in let* info = lift (WASM_machine.get_info s) in return @@ Sc_rollup_tick_repr.of_z info.current_tick - let get_tick : state -> Sc_rollup_tick_repr.t Lwt.t = result_of get_tick + let get_tick : state -> Sc_rollup_tick_repr.t Lwt.t = result_of get_tick_aux - let get_status : status Monad.t = + let get_status_aux : status Monad.t = let open Monad.Syntax in let* s = get in let* info = lift (WASM_machine.get_info s) in @@ -232,9 +233,9 @@ module V2_0_0 = struct Some (inbox_level, message_counter) | _ -> None - let is_input_state = + let is_input_state_aux = let open Monad.Syntax in - let* status = get_status in + let* status = get_status_aux in match status with | WaitingForInputMessage -> ( let* last_read = get_last_message_read in @@ -243,9 +244,9 @@ module V2_0_0 = struct | None -> return PS.Initial) | Computing -> return PS.No_input_required - let is_input_state = result_of is_input_state + let is_input_state = result_of is_input_state_aux - let get_status : state -> status Lwt.t = result_of get_status + let get_status : state -> status Lwt.t = result_of get_status_aux let set_input_state input = let open PS in @@ -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 kinded_hash_to_state_hash : Context.Proof.kinded_hash -> _ = + function | `Value hash | `Node hash -> State_hash.hash_bytes [Context_hash.to_bytes hash] let 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 proof_after proof = + kinded_hash_to_state_hash proof.Context.Proof.after - let proof_encoding = Context.Proof_encoding.V1.Tree32.tree_proof_encoding + let 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..3fa15ec8a2c74 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 = @@ -165,13 +165,15 @@ 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 + let module P : PVM_with_proof + with type proof = + Sc_rollup_arith.ProtocolImplementation.proof = struct include Sc_rollup_arith.ProtocolImplementation - let proof = proof + let proof_val = proof end in Arith_pvm_with_proof (module P)); case @@ -185,13 +187,15 @@ 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 + let module P : PVM_with_proof + with type proof = + Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof = 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)); ] @@ -205,14 +209,15 @@ let wrap_proof pvm_with_proof = | Some Kind.Example_arith -> Option.map (fun arith_proof -> - let module P_arith = struct + let module P_arith : + PVM_with_proof with type proof = Sc_rollup_arith.ProtocolImplementation.proof = 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 @@ -220,14 +225,15 @@ let wrap_proof pvm_with_proof = | Some Kind.Wasm_2_0_0 -> Option.map (fun wasm_proof -> - let module P_wasm2_0_0 = struct + let module P_wasm2_0_0 : + PVM_with_proof with type proof = Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof = 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..265ab740a0b8a 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_interpreter.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_interpreter.ml @@ -234,6 +234,17 @@ let () = *) +let ifailwith : ifailwith_type = + { + ifailwith = + (fun logger (ctxt, _) gas kloc tv v -> + 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 +262,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 +283,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 +301,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 +335,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 +367,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 +380,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,105 +401,93 @@ 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 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 = 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 + 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 (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 + 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 (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 arg = accu in let code, stack = stack in let (Lam (code, _)) = code in let code = match logger with @@ -494,9 +496,9 @@ 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 = +and[@coq_mutual_as_notation] iview : type a b c d e f i o. (a, b, c, d, e, f, i, o) iview_type = fun instrument (ctxt, sc) gas @@ -511,7 +513,7 @@ and iview : type a b c d e f i o. (a, b, c, d, e, f, i, o) iview_type = 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 addr.destination with | Contract (Implicit _) | Tx_rollup _ | Sc_rollup _ -> @@ -585,31 +587,35 @@ 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 = - fun ((ctxt, sc) as g) gas i ks accu stack -> +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 (_, 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) -> - let x = accu and y, stack = stack in + | 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 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]) @@ -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,8 +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 [@ocaml.tailcall]) + | IView (_, view_signature, stack_ty, k), _, (stack : address * _) -> + (iview [@ocaml.tailcall] [@coq_implicit "o" "__IView_'b"]) id g gas @@ -1153,7 +1235,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 +1245,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 +1254,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 +1282,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 +1332,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 +1345,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 : - type a s b t. - (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness -> - a -> - s -> - b * t = + 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 +1401,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 +1426,227 @@ 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 : - type a b s c d t. - (a, b, s, c, d, t) comb_gadt_witness -> a * (b * s) -> c * (d * t) + | IComb (_, _, witness, k), _, (stack : _ * _) -> + 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) -> + match[@coq_match_gadt] (witness, stack) with + | Comb_one, _ -> stack[@coq_cast] + | Comb_succ witness', (stack : _ * (_ * (_ * _))) -> + let a, tl = stack in let b, tl' = aux witness' tl in - ((a, b), tl') + (((a, b[@coq_type_annotation])[@coq_cast] : c'), tl') in let stack = aux witness (accu, stack) in - let accu, stack = stack in + let accu, stack = stack[@coq_type_annotation] in (step [@ocaml.tailcall]) g gas k ks accu stack - | IUncomb (_, _, witness, k) -> - let rec aux : - type a b s c d t. - (a, b, s, c, d, t) uncomb_gadt_witness -> - a * (b * s) -> - c * (d * t) = + | IUncomb (_, _, witness, k), _, (stack : _ * _) -> + 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_with_result] (witness, stack) with + | Uncomb_one, _ -> stack + | Uncomb_succ witness', (stack : (_ * _) * _) -> + let (a, b), tl = stack in + let result = (aux[@coq_type_annotation]) witness' (b, tl) in + (a, result) in let stack = aux witness (accu, stack) in - let accu, stack = stack in + let accu, stack = stack[@coq_type_annotation] 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 : - type a b before after. - (a, b, before, after) dup_n_gadt_witness -> - a * (b * before) -> + | IDup_n (_, _, witness, k), _, (stack : _ * _) -> + 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, _ -> + let a, _ = stack in + (a[@coq_cast]) + | 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 +1658,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 +1679,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 +1698,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 +1729,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 +1940,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 +2087,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 +2109,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 +2130,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 +2160,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_interpreter_logging.ml b/src/proto_014_PtKathma/lib_protocol/script_interpreter_logging.ml index 39a7eb3071ef6..c40e3d9628f5f 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_interpreter_logging.ml +++ b/src/proto_014_PtKathma/lib_protocol/script_interpreter_logging.ml @@ -98,11 +98,13 @@ type ('a, 's, 'r, 'f) ex_split_kinstr = cast : ('a, 's) failed_kinstr_cast; } -> ('a, 's, 'r, 'f) ex_split_kinstr +[@@coq_force_gadt] type ('r, 'f) ex_init_stack_ty = | Ex_init_stack_ty : ('a, 's) stack_ty * ('a, 's, 'r, 'f) kinstr -> ('r, 'f) ex_init_stack_ty +[@@coq_force_gadt] let rec stack_prefix_preservation_witness_split_input : type a s b t c u d v. @@ -110,7 +112,7 @@ let rec stack_prefix_preservation_witness_split_input : (a, s) stack_ty -> (b, t) stack_ty = fun w s -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | KPrefix (_, _, w), Item_t (_, s) -> stack_prefix_preservation_witness_split_input w s | KRest, s -> s @@ -133,7 +135,7 @@ let kinstr_split : (a, s, r, f) ex_split_kinstr tzresult = fun s i -> let dummy = Micheline.dummy_location in - match (i, s) with + match[@coq_match_with_default] (i, s) with | IDrop (loc, k), Item_t (_a, s) -> ok @@ Ex_split_kinstr @@ -245,7 +247,7 @@ let kinstr_split : body; continuation = k; aft_body_stack_transform = - (function + (function[@coq_match_with_default] | Item_t (b, s) -> option_t dummy b >|? fun o -> Item_t (o, s)); reconstruct = (fun body k -> IOpt_map {loc; body; k}); } @@ -322,7 +324,7 @@ let kinstr_split : body; continuation = k; aft_body_stack_transform = - (function + (function[@coq_match_with_default] | Item_t (b, s) -> list_t dummy b >|? fun l -> Item_t (l, s)); reconstruct = (fun body k -> IList_map (loc, body, ty, k)); } @@ -400,18 +402,19 @@ let kinstr_split : reconstruct = (fun k -> IEmpty_map (loc, cty, vty, k)); } | IMap_map (loc, ty, body, k), Item_t (Map_t (kty, vty, _meta), s) -> - let (Map_t (key_ty, _, _)) = ty in - pair_t dummy key_ty vty >|? fun (Ty_ex_c p) -> - Ex_split_loop_may_not_fail - { - body_init_stack = Item_t (p, s); - body; - continuation = k; - aft_body_stack_transform = - (fun (Item_t (b, s)) -> - map_t dummy kty b >|? fun m -> Item_t (m, s)); - reconstruct = (fun body k -> IMap_map (loc, ty, body, k)); - } + (match[@coq_match_with_default] ty with + | Map_t (key_ty, _, _) -> + pair_t dummy key_ty vty >|? fun (Ty_ex_c p) -> + Ex_split_loop_may_not_fail + { + body_init_stack = Item_t (p, s); + body; + continuation = k; + aft_body_stack_transform = + (fun[@coq_match_with_default] (Item_t (b, s)) -> + map_t dummy kty b >|? fun m -> Item_t (m, s)); + reconstruct = (fun body k -> IMap_map (loc, ty, body, k)); + }) | IMap_iter (loc, kvty, body, k), Item_t (_, stack) -> ok @@ Ex_split_loop_may_fail @@ -925,16 +928,16 @@ let kinstr_split : } | ILambda (loc, l, k), s -> let (Lam (desc, _)) = l in - let (Item_t (a, Bot_t)) = desc.kbef in - let (Item_t (b, Bot_t)) = desc.kaft in - lambda_t dummy a b >|? fun lam -> - let s = Item_t (lam, s) in - Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> ILambda (loc, l, k)); - } + (match[@coq_match_with_default] desc.kbef, desc.kaft with + | Item_t (a, Bot_t), Item_t (b, Bot_t) -> + lambda_t dummy a b >|? fun lam -> + let s = Item_t (lam, s) in + Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> ILambda (loc, l, k)); + }) | IFailwith (location, arg_ty), _ -> ok @@ Ex_split_failwith @@ -1230,16 +1233,17 @@ let kinstr_split : reconstruct = (fun k -> ISapling_verify_update (loc, k)); } | IDig (loc, n, p, k), s -> - let (Item_t (b, s)) = stack_prefix_preservation_witness_split_input p s in - let s = stack_prefix_preservation_witness_split_output p s in - let s = Item_t (b, s) in - ok - @@ Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> IDig (loc, n, p, k)); - } + (match[@coq_match_with_default] stack_prefix_preservation_witness_split_input p s with + | Item_t (b, s) -> + let s = stack_prefix_preservation_witness_split_output p s in + let s = Item_t (b, s) in + ok + @@ Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> IDig (loc, n, p, k)); + }) | IDug (loc, n, p, k), Item_t (a, s) -> let s = stack_prefix_preservation_witness_split_input p s in let s = Item_t (a, s) in @@ -1434,10 +1438,10 @@ let kinstr_split : (a, b, s, c, d, t) comb_gadt_witness -> (c, d * t) stack_ty tzresult = fun s w -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | Comb_one, s -> ok s | Comb_succ w, Item_t (a, s) -> - aux s w >>? fun (Item_t (c, t)) -> + aux s w >>? fun[@coq_match_with_default] (Item_t (c, t)) -> pair_t dummy a c >|? fun (Ty_ex_c p) -> Item_t (p, t) in aux s p >|? fun s -> @@ -1454,7 +1458,7 @@ let kinstr_split : (a, b, s, c, d, t) uncomb_gadt_witness -> (c, d * t) stack_ty = fun s w -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | Uncomb_one, s -> s | Uncomb_succ w, Item_t (Pair_t (a, b, _meta, _), s) -> let s = aux (Item_t (b, s)) w in @@ -1472,7 +1476,7 @@ let kinstr_split : let rec aux : type c cc a. (c, cc) ty -> (c, a) comb_get_gadt_witness -> a ty_ex_c = fun c w -> - match (w, c) with + match[@coq_match_with_default] (w, c) with | Comb_get_zero, c -> Ty_ex_c c | Comb_get_one, Pair_t (hd, _tl, _meta, _) -> Ty_ex_c hd | Comb_get_plus_two w, Pair_t (_hd, tl, _meta, _) -> aux tl w @@ -1496,7 +1500,7 @@ let kinstr_split : (a, b, c) comb_set_gadt_witness -> c ty_ex_c tzresult = fun a b w -> - match (w, b) with + match[@coq_match_with_default] (w, b) with | Comb_set_zero, _ -> ok (Ty_ex_c a) | Comb_set_one, Pair_t (_hd, tl, _meta, _) -> pair_t dummy a tl | Comb_set_plus_two w, Pair_t (hd, tl, _meta, _) -> @@ -1515,7 +1519,7 @@ let kinstr_split : type a b s t. (a, b * s) stack_ty -> (a, b, s, t) dup_n_gadt_witness -> t ty_ex_c = fun s w -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | Dup_n_succ w, Item_t (_, s) -> aux s w | Dup_n_zero, Item_t (a, _) -> Ty_ex_c a in @@ -1606,7 +1610,7 @@ let kinstr_split : reconstruct = (fun k -> ILog (loc, s, event, logger, k)); } -let rec kinstr_final_stack_type : +let[@coq_struct "i_value"] rec kinstr_final_stack_type : type a s r f. (a, s) stack_ty -> (a, s, r, f) kinstr -> (r, f) stack_ty option tzresult = fun s i -> @@ -1770,16 +1774,18 @@ let log_next_continuation : | None -> KCons (ki', k) | Some sty -> KCons (ki', instrument_cont logger sty k)) | KLoop_in (ki, k) -> - let (Item_t (Bool_t, sty)) = stack_ty in - ok @@ KLoop_in (enable_log sty ki, instrument_cont logger sty k) + (match[@coq_match_with_default] stack_ty with + | Item_t (Bool_t, sty) -> + ok @@ KLoop_in (enable_log sty ki, instrument_cont logger sty k)) | KReturn (stack, sty, k) -> let k' = instrument_cont logger sty k in ok @@ KReturn (stack, sty, k') | KLoop_in_left (ki, k) -> - let (Item_t (Union_t (a_ty, b_ty, _, _), rest)) = stack_ty in - let ki' = enable_log (Item_t (a_ty, rest)) ki in - let k' = instrument_cont logger (Item_t (b_ty, rest)) k in - ok @@ KLoop_in_left (ki', k') + (match[@coq_match_with_default] stack_ty with + | Item_t (Union_t (a_ty, b_ty, _, _), rest) -> + let ki' = enable_log (Item_t (a_ty, rest)) ki in + let k' = instrument_cont logger (Item_t (b_ty, rest)) k in + ok @@ KLoop_in_left (ki', k')) | KUndip (x, ty, k) -> let k' = instrument_cont logger (Item_t (ty, stack_ty)) k in ok @@ KUndip (x, ty, k') @@ -1791,16 +1797,18 @@ let log_next_continuation : let k' = instrument_cont logger (Item_t (ty, stack_ty)) k in ok @@ KList_enter_body (body, xs, ys, ty, len, k') | KList_exit_body (body, xs, ys, ty, len, k) -> - let (Item_t (_, sty)) = stack_ty in - let k' = instrument_cont logger (Item_t (ty, sty)) k in - ok @@ KList_exit_body (body, xs, ys, ty, len, k') + (match[@coq_match_with_default] stack_ty with + | Item_t (_, sty) -> + let k' = instrument_cont logger (Item_t (ty, sty)) k in + ok @@ KList_exit_body (body, xs, ys, ty, len, k')) | KMap_enter_body (body, xs, ys, ty, k) -> let k' = instrument_cont logger (Item_t (ty, stack_ty)) k in ok @@ KMap_enter_body (body, xs, ys, ty, k') | KMap_exit_body (body, xs, ys, yk, ty, k) -> - let (Item_t (_, sty)) = stack_ty in - let k' = instrument_cont logger (Item_t (ty, sty)) k in - ok @@ KMap_exit_body (body, xs, ys, yk, ty, k') + (match[@coq_match_with_default] stack_ty with + | Item_t (_, sty) -> + let k' = instrument_cont logger (Item_t (ty, sty)) k in + ok @@ KMap_exit_body (body, xs, ys, yk, ty, k')) | KMap_head (_, _) | KView_exit (_, _) | KLog _ (* This case should never happen. *) | KNil -> @@ -1812,6 +1820,6 @@ let rec dipn_stack_ty : (c, u) stack_ty -> (a, s) stack_ty = fun witness stack -> - match (witness, stack) with + match[@coq_match_with_default] (witness, stack) with | KPrefix (_, _, witness'), Item_t (_, sty) -> dipn_stack_ty witness' sty | KRest, sty -> sty diff --git a/src/proto_014_PtKathma/lib_protocol/script_interpreter_logging.mli b/src/proto_014_PtKathma/lib_protocol/script_interpreter_logging.mli index f2e26a0cef56e..7cfd10edc4824 100644 --- a/src/proto_014_PtKathma/lib_protocol/script_interpreter_logging.mli +++ b/src/proto_014_PtKathma/lib_protocol/script_interpreter_logging.mli @@ -33,6 +33,7 @@ type ('r, 'f) ex_init_stack_ty = | Ex_init_stack_ty : ('a, 's) stack_ty * ('a, 's, 'r, 'f) kinstr -> ('r, 'f) ex_init_stack_ty +[@@coq_force_gadt] (** [log_kinstr logger sty instr] returns [instr] prefixed by an [ILog] instruction to log the first instruction in [instr]. Note 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..2a3ccb033825d 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} @@ -466,7 +469,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = Script.location * ('b, 'a * ('c * 's), 'r, 'f) kinstr -> ('a, 'b * ('c * 's), 'r, 'f) kinstr | IConst : - Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 's, 'r, 'f) kinstr + Script.location * ('t, _) ty * 't * ('t, 'a * 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr (* Pairs @@ -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 : { @@ -1400,7 +1408,7 @@ and operation = { lazy_storage_diff : Lazy_storage.diffs option; } -type ('arg, 'storage) script = +type (_, 'storage) script = | Script : { code : (('arg, 'storage) pair, (operation boxed_list, 'storage) pair) lambda; @@ -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..a0d5453b87899 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 @@ -427,7 +429,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = Script.location * ('b, 'a * ('c * 's), 'r, 'f) kinstr -> ('a, 'b * ('c * 's), 'r, 'f) kinstr | IConst : - Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 's, 'r, 'f) kinstr + Script.location * ('t, _) ty * 't * ('t, 'a * 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr (* Pairs @@ -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 : { @@ -1536,7 +1542,7 @@ and operation = { lazy_storage_diff : Lazy_storage.diffs option; } -type ('arg, 'storage) script = +type (_, 'storage) script = | Script : { code : (('arg, 'storage) pair, (operation boxed_list, 'storage) pair) lambda; @@ -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..1543223a2acfd 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) @@ -1210,8 +1210,9 @@ end (** Seed *) -module Seed_status = - Make_single_data_storage (Registered) (Raw_context) +module Seed_status : + Single_data_storage with type t := Raw_context.t and type value = Seed_repr.seed_status = + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["seed_status"] end) @@ -1266,7 +1267,7 @@ module Seed = struct end module VDF_setup = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["vdf_challenge"] end) @@ -1301,7 +1302,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 +1320,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 +1356,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 +1367,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 +1402,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 +1410,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 +1427,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 +1450,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 +1530,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) @@ -1537,58 +1543,59 @@ module Sc_rollup = struct end)) (Make_index (Sc_rollup_repr.Index)) - module Make_versioned - (Versioned_value : Sc_rollup_data_version_sig.S) (Data_storage : sig - type context + module type DATA_STORAGE = sig + type context - type key + type key - type value = Versioned_value.versioned + type value - val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t + val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t - val find : - context -> key -> (Raw_context.t * value option) tzresult Lwt.t + val find : + context -> key -> (Raw_context.t * value option) tzresult Lwt.t - val update : - context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + val update : + context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t - val init : - context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + val init : + context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t - val add : - context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t + val add : + context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t - val add_or_remove : - context -> - key -> - value option -> - (Raw_context.t * int * bool) tzresult Lwt.t - end) = - struct - include Data_storage + val add_or_remove : + context -> + key -> + value option -> + (Raw_context.t * int * bool) tzresult Lwt.t + end + module Make_versioned + (Versioned_value : Sc_rollup_data_version_sig.S) + (Data_storage : DATA_STORAGE with type value = Versioned_value.versioned) = + struct type value = Versioned_value.t let get ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = get ctxt key in + let* ctxt, versioned = Data_storage.get ctxt key in return (ctxt, Versioned_value.of_versioned versioned) let find ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = find ctxt key in + let* ctxt, versioned = Data_storage.find ctxt key in return (ctxt, Option.map Versioned_value.of_versioned versioned) let update ctxt key value = - update ctxt key (Versioned_value.to_versioned value) + Data_storage.update ctxt key (Versioned_value.to_versioned value) - let init ctxt key value = init ctxt key (Versioned_value.to_versioned value) + let init ctxt key value = Data_storage.init ctxt key (Versioned_value.to_versioned value) - let add ctxt key value = add ctxt key (Versioned_value.to_versioned value) + let add ctxt key value = Data_storage.add ctxt key (Versioned_value.to_versioned value) let add_or_remove ctxt key value = - add_or_remove ctxt key (Option.map Versioned_value.to_versioned value) + Data_storage.add_or_remove ctxt key (Option.map Versioned_value.to_versioned value) end module PVM_kind = @@ -1646,8 +1653,22 @@ module Sc_rollup = struct let encoding = Sc_rollup_inbox_repr.versioned_encoding end) - module Inbox = struct - include Inbox_versioned + module Inbox : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_repr.t + and type value = Sc_rollup_inbox_repr.t + and type t := Raw_context.t = + struct + type context = Inbox_versioned.context + + type key = Inbox_versioned.key + + let mem = Inbox_versioned.mem + + let remove_existing = Inbox_versioned.remove_existing + + let remove = Inbox_versioned.remove + include Make_versioned (Sc_rollup_inbox_repr) (Inbox_versioned) end @@ -1662,7 +1683,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 @@ -1699,12 +1724,34 @@ module Sc_rollup = struct let encoding = Sc_rollup_commitment_repr.versioned_encoding end) - module Commitments = struct - include Commitments_versioned - include Make_versioned (Sc_rollup_commitment_repr) (Commitments_versioned) + module Commitments : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = Sc_rollup_commitment_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = + struct + type t = Commitments_versioned.t + + type context = Commitments_versioned.context + + type key = Commitments_versioned.key + + let mem = Commitments_versioned.mem + + let remove_existing = Commitments_versioned.remove_existing + + let remove = Commitments_versioned.remove + + module M = Make_versioned (Sc_rollup_commitment_repr) (Commitments_versioned) + + include M 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 +1764,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 @@ -1743,12 +1794,34 @@ module Sc_rollup = struct let encoding = Sc_rollup_game_repr.versioned_encoding end) - module Game = struct - include Game_versioned - include Make_versioned (Sc_rollup_game_repr) (Game_versioned) + module Game : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.t + and type value = Sc_rollup_game_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = + struct + type t = Game_versioned.t + + type context = Game_versioned.context + + type key = Game_versioned.key + + let mem = Game_versioned.mem + + let remove_existing = Game_versioned.remove_existing + + let remove = Game_versioned.remove + + module M = Make_versioned (Sc_rollup_game_repr) (Game_versioned) + + include M end - module Game_timeout = + module Game_timeout : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.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 +1834,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 @@ -1862,7 +1939,7 @@ end module Dal = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["dal"] end) @@ -1879,7 +1956,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.mli b/src/proto_014_PtKathma/lib_protocol/storage.mli index 9fd408a5e7bbb..f5c5143863564 100644 --- a/src/proto_014_PtKathma/lib_protocol/storage.mli +++ b/src/proto_014_PtKathma/lib_protocol/storage.mli @@ -480,7 +480,7 @@ end (** Seed *) module Seed_status : - Simple_single_data_storage with type value = Seed_repr.seed_status + Single_data_storage with type t := Raw_context.t and type value = Seed_repr.seed_status module Seed : sig (** Storage from this submodule must only be accessed through the diff --git a/src/proto_014_PtKathma/lib_protocol/storage_description.ml b/src/proto_014_PtKathma/lib_protocol/storage_description.ml index 86aed867ac161..06754a5836a48 100644 --- a/src/proto_014_PtKathma/lib_protocol/storage_description.ml +++ b/src/proto_014_PtKathma/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,17 +167,17 @@ 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 let list_right r = - let a, k = unpack left r in + let (a, k) = unpack left r in list a >|=? fun l -> List.map snd (List.filter (fun (x, _) -> equal_left x k) 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_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..2309556dde121 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_struct "hty"] rec tickets_of_value_aux : type a ac ret. include_lazy:bool -> allow_zero_amount_tickets:bool -> @@ -333,11 +333,11 @@ module Ticket_collection = struct fun ~include_lazy ~allow_zero_amount_tickets 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][@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 ~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 @@ -355,10 +355,10 @@ module Ticket_collection = struct r acc k) - | Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _) -> ( + | Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _), (x : _ Script_typed_ir.union) -> ( 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 @@ -377,10 +377,10 @@ module Ticket_collection = struct v acc k) - | Option_ht el_hty, Option_t (el_ty, _, _) -> ( + | Option_ht el_hty, Option_t (el_ty, _, _), (x : _ option) -> ( match x with | Some x -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt @@ -390,7 +390,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 @@ -401,9 +401,9 @@ 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 : _ map) -> (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty @@ -418,9 +418,9 @@ 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 : _ big_map) -> if include_lazy then - (tickets_of_big_map [@ocaml.tailcall]) + (tickets_of_big_map [@ocaml.tailcall] [@coq_implicit "v" "__10"]) ctxt ~allow_zero_amount_tickets val_hty @@ -429,7 +429,7 @@ module Ticket_collection = struct acc k else (k [@ocaml.tailcall]) ctxt acc - | True_ht, Ticket_t (comp_ty, _) -> + | True_ht, Ticket_t (comp_ty, _), (x : _ ticket) -> let Script_typed_ir.{ticketer = _; contents = _; amount} = x in fail_when ((not allow_zero_amount_tickets) @@ -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_struct "elements"] 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_mutual_as_notation] 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_mutual_as_notation] 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..8321d96f50be8 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 "extensible type in pattern"] 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..9abcb80c95600 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 "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 @@ -154,31 +155,40 @@ let compute_proof_after_hash ~max_proof_size ctxt parameters agreed proof ~proof_size:proof_length >>?= fun ctxt -> verify_l2_proof proof parameters message >>= fun res -> - match res with - | (Ok _ | Error (`Stream_too_short _)) when proof_is_too_long -> - (* If the proof is larger than [max_proof_size] we care about 2 cases: - - - The proof verification succedeed but should not be considered valid - since it is larger than the size limit - - The proof verification failed because it was truncated but was - already larger than the size limit - - In those two cases, the expected after hash is - [after_hash_when_proof_failed] because the correct commitment is - "we were not able to apply this message, so after is the same - as before" - *) - after_hash_when_proof_failed ctxt agreed >>?= fun res -> return res - | Ok (tree, withdrawals) -> - (* The proof is small enough, we compare the computed hash with the - committed one *) - let tree_hash = Context.Tree.hash tree in - Tx_rollup_hash.withdraw_list ctxt withdrawals - >>?= fun (ctxt, withdrawals) -> - hash_message_result ctxt tree_hash withdrawals >>?= fun res -> return res - | Error _ -> - (* Finally, the proof verification leads to an internal Irmin error *) - fail Proof_failed_to_reject + if proof_is_too_long && + (* If the proof is larger than [max_proof_size] we care about 2 cases: + + - The proof verification succedeed but should not be considered valid + since it is larger than the size limit + - The proof verification failed because it was truncated but was + already larger than the size limit + + In those two cases, the expected after hash is + [after_hash_when_proof_failed] because the correct commitment is + "we were not able to apply this message, so after is the same + as before" + *) + match res with + | Ok _ -> true + | Error error -> + match error with + | `Stream_too_long _ -> true + | _ -> false + then + after_hash_when_proof_failed ctxt agreed >>?= fun res -> return res + else + match res with + | Ok (tree, withdrawals) -> + (* The proof is small enough, we compare the computed hash with the + committed one *) + let tree_hash = Context.Tree.hash tree in + Tx_rollup_hash.withdraw_list ctxt withdrawals + >>?= fun (ctxt, withdrawals) -> + hash_message_result ctxt tree_hash withdrawals >>?= fun res -> + return res + | Error _ -> + (* Finally, the proof verification leads to an internal Irmin error *) + fail Proof_failed_to_reject let verify_proof ctxt parameters message proof ~(agreed : Tx_rollup_message_result.t) ~rejected ~max_proof_size = 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..4255ea76d7380 100644 --- a/src/proto_014_PtKathma/lib_protocol/validate_operation.ml +++ b/src/proto_014_PtKathma/lib_protocol/validate_operation.ml @@ -300,7 +300,7 @@ module Manager = struct counter -> kind Kind.manager contents_list -> unit tzresult = - fun expected_source previous_counter -> function + fun expected_source previous_counter -> function[@coq_match_with_default] | Single (Manager_operation {operation = Reveal _key; _}) -> error Incorrect_reveal_position | Cons (Manager_operation {operation = Reveal _key; _}, _res) -> @@ -327,7 +327,7 @@ module Manager = struct kind Kind.manager contents_list -> (public_key_hash * public_key option * counter) tzresult = fun contents_list -> - match contents_list with + match[@coq_match_with_default] contents_list with | Single (Manager_operation {source; operation = Reveal key; counter; _}) -> ok (source, Some key, counter) @@ -435,7 +435,7 @@ module Manager = struct let validate_tx_rollup_dispatch_tickets vi remaining_gas operation = let open Result_syntax in let* () = assert_tx_rollup_feature_enabled vi in - let (Tx_rollup_dispatch_tickets {tickets_info; message_result_path; _}) = + let[@coq_match_with_default] (Tx_rollup_dispatch_tickets {tickets_info; message_result_path; _}) = operation in let Constants.Parametric. @@ -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 @@ -472,7 +472,7 @@ module Manager = struct let validate_tx_rollup_rejection vi operation = let open Result_syntax in let* () = assert_tx_rollup_feature_enabled vi in - let (Tx_rollup_rejection + let[@coq_match_with_default] (Tx_rollup_rejection {message_path; message_result_path; previous_message_result_path; _}) = operation @@ -482,25 +482,25 @@ 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 let validate_contents (type kind) vi batch_state (contents : kind Kind.manager contents) = let open Lwt_result_syntax in - let (Manager_operation + let[@coq_match_with_default] (Manager_operation {source; fee; counter = _; operation; gas_limit; storage_limit}) = contents in @@ -665,7 +665,7 @@ let validate_operation (vi : validate_operation_info) = let open Lwt_result_syntax in let* vs = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Manager_operation {source; _}) -> Manager.validate_manager_operation vi vs source oph operation | Cons (Manager_operation {source; _}, _) -> @@ -722,7 +722,7 @@ module TMP_for_plugin = struct let vi, vs = init_info_and_state ctxt Mempool chain_id in precheck_manager vi vs contents_list should_check_signature in - match contents_list with + match[@coq_match_with_default] contents_list with | Single (Manager_operation _) -> handle_manager contents_list | Cons (Manager_operation _, _) -> handle_manager contents_list | Single (Preendorsement _) diff --git a/src/proto_014_PtKathma/lib_protocol/voting_services.ml b/src/proto_014_PtKathma/lib_protocol/voting_services.ml index 2422274c5d52b..b005d4d47a9c2 100644 --- a/src/proto_014_PtKathma/lib_protocol/voting_services.ml +++ b/src/proto_014_PtKathma/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 () () diff --git a/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.ml b/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.ml index 8493f18a7e13f..d6e8bc1830c61 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.ml @@ -1,3 +1,4 @@ + (*****************************************************************************) (* *) (* Open Source License *) @@ -78,10 +79,12 @@ let init ctxt chain_id ~predecessor_level ~predecessor_round ~predecessor_hash {predecessor_hash; operation_state; operations = Operation_hash.Map.empty} ) +type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * packed_operation -> new_operation:Operation_hash.t * packed_operation -> - [`Keep | `Replace] + keep_or_replace let remove_operation mempool oph = match Operation_hash.Map.find_opt oph mempool.operations with @@ -128,8 +131,8 @@ let add_operation ?(check_signature = true) | Some op -> (existing, op) in match handler ~existing_operation ~new_operation with - | `Keep -> Lwt.return_ok (mempool, Unchanged) - | `Replace -> + | Keep -> Lwt.return_ok (mempool, Unchanged) + | Replace -> let mempool = remove_operation mempool existing in let operation_state = add_valid_operation @@ -183,8 +186,8 @@ let merge ?conflict_handler existing_mempool new_mempool = ~existing_operation:(existing, existing_operation_content) ~new_operation:(new_operation, new_operation_content) with - | `Keep -> Ok `Do_nothing - | `Replace -> Ok (`Replace existing)) + | Keep -> Ok `Do_nothing + | Replace -> Ok (`Replace existing)) in Operation_hash.Map.fold_e (fun roph packed_right_op mempool_acc -> diff --git a/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.mli b/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.mli index 6ed036b88545c..01e7a89b15ca0 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.mli +++ b/src/proto_015_PtLimaPt/lib_protocol/mempool_validation.mli @@ -61,6 +61,8 @@ type t mempool. *) type validation_info +type keep_or_replace = Keep | Replace + (** Type of the function that may be provided in order to resolve a potential conflict when adding an operation to an existing mempool or when merging two mempools. This handler may be defined as a @@ -74,7 +76,7 @@ type validation_info type conflict_handler = existing_operation:Operation_hash.t * packed_operation -> new_operation:Operation_hash.t * packed_operation -> - [`Keep | `Replace] + keep_or_replace (** Return type when adding an operation to the mempool *) type add_result = diff --git a/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml b/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml index d09762eca53a0..8b755e26f60cb 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml @@ -98,11 +98,13 @@ type ('a, 's, 'r, 'f) ex_split_kinstr = cast : ('a, 's) failed_kinstr_cast; } -> ('a, 's, 'r, 'f) ex_split_kinstr +[@@coq_force_gadt] type ('r, 'f) ex_init_stack_ty = | Ex_init_stack_ty : ('a, 's) stack_ty * ('a, 's, 'r, 'f) kinstr -> ('r, 'f) ex_init_stack_ty +[@@coq_force_gadt] let rec stack_prefix_preservation_witness_split_input : type a s b t c u d v. @@ -110,7 +112,7 @@ let rec stack_prefix_preservation_witness_split_input : (a, s) stack_ty -> (b, t) stack_ty = fun w s -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | KPrefix (_, _, w), Item_t (_, s) -> stack_prefix_preservation_witness_split_input w s | KRest, s -> s @@ -137,7 +139,7 @@ let kinstr_split : (a, s, r, f) ex_split_kinstr tzresult = fun s i -> let dummy = Micheline.dummy_location in - match (i, s) with + match[@coq_match_with_default] (i, s) with | IDrop (loc, k), Item_t (_a, s) -> ok @@ Ex_split_kinstr @@ -249,7 +251,7 @@ let kinstr_split : body; continuation = k; aft_body_stack_transform = - (function + (function[@coq_match_with_default] | Item_t (b, s) -> option_t dummy b >|? fun o -> Item_t (o, s)); reconstruct = (fun body k -> IOpt_map {loc; body; k}); } @@ -326,7 +328,7 @@ let kinstr_split : body; continuation = k; aft_body_stack_transform = - (function + (function[@coq_match_with_default] | Item_t (b, s) -> list_t dummy b >|? fun l -> Item_t (l, s)); reconstruct = (fun body k -> IList_map (loc, body, ty, k)); } @@ -403,19 +405,20 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> IEmpty_map (loc, cty, vty, k)); } - | IMap_map (loc, ty, body, k), Item_t (Map_t (kty, vty, _meta), s) -> - let (Map_t (key_ty, _, _)) = assert_some ty in - pair_t dummy key_ty vty >|? fun (Ty_ex_c p) -> - Ex_split_loop_may_not_fail - { - body_init_stack = Item_t (p, s); - body; - continuation = k; - aft_body_stack_transform = - (fun (Item_t (b, s)) -> - map_t dummy kty b >|? fun m -> Item_t (m, s)); - reconstruct = (fun body k -> IMap_map (loc, ty, body, k)); - } + | IMap_map (loc, ty, body, k), Item_t (Map_t (kty, vty, _meta), s) -> ( + match[@coq_match_with_default] assert_some ty with + | Map_t (key_ty, _, _) -> + pair_t dummy key_ty vty >|? fun (Ty_ex_c p) -> + Ex_split_loop_may_not_fail + { + body_init_stack = Item_t (p, s); + body; + continuation = k; + aft_body_stack_transform = + (fun [@coq_match_with_default] (Item_t (b, s)) -> + map_t dummy kty b >|? fun m -> Item_t (m, s)); + reconstruct = (fun body k -> IMap_map (loc, ty, body, k)); + }) | IMap_iter (loc, kvty, body, k), Item_t (_, stack) -> ok @@ Ex_split_loop_may_fail @@ -927,28 +930,28 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> IApply (loc, ty, k)); } - | ILambda (loc, (Lam (desc, _) as l), k), s -> - let (Item_t (a, Bot_t)) = desc.kbef in - let (Item_t (b, Bot_t)) = desc.kaft in - lambda_t dummy a b >|? fun lam -> - let s = Item_t (lam, s) in - Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> ILambda (loc, l, k)); - } - | ILambda (loc, (LamRec (desc, _) as l), k), s -> - let (Item_t (a, Item_t (Lambda_t _, Bot_t))) = desc.kbef in - let (Item_t (b, Bot_t)) = desc.kaft in - lambda_t dummy a b >|? fun lam -> - let s = Item_t (lam, s) in - Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> ILambda (loc, l, k)); - } + | ILambda (loc, (Lam (desc, _) as l), k), s -> ( + match[@coq_match_with_default] (desc.kbef, desc.kaft) with + | Item_t (a, Bot_t), Item_t (b, Bot_t) -> + lambda_t dummy a b >|? fun lam -> + let s = Item_t (lam, s) in + Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> ILambda (loc, l, k)); + }) + | ILambda (loc, (LamRec (desc, _) as l), k), s -> ( + match[@coq_match_with_default] (desc.kbef, desc.kaft) with + | Item_t (a, Item_t (Lambda_t _, Bot_t)), Item_t (b, Bot_t) -> + lambda_t dummy a b >|? fun lam -> + let s = Item_t (lam, s) in + Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> ILambda (loc, l, k)); + }) | IFailwith (location, arg_ty), _ -> ok @@ Ex_split_failwith @@ -1243,17 +1246,20 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> ISapling_verify_update (loc, k)); } - | IDig (loc, n, p, k), s -> - let (Item_t (b, s)) = stack_prefix_preservation_witness_split_input p s in - let s = stack_prefix_preservation_witness_split_output p s in - let s = Item_t (b, s) in - ok - @@ Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> IDig (loc, n, p, k)); - } + | IDig (loc, n, p, k), s -> ( + match[@coq_match_with_default] + stack_prefix_preservation_witness_split_input p s + with + | Item_t (b, s) -> + let s = stack_prefix_preservation_witness_split_output p s in + let s = Item_t (b, s) in + ok + @@ Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> IDig (loc, n, p, k)); + }) | IDug (loc, n, p, k), Item_t (a, s) -> let s = stack_prefix_preservation_witness_split_input p s in let s = Item_t (a, s) in @@ -1448,10 +1454,10 @@ let kinstr_split : (a, b, s, c, d, t) comb_gadt_witness -> (c, d * t) stack_ty tzresult = fun s w -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | Comb_one, s -> ok s | Comb_succ w, Item_t (a, s) -> - aux s w >>? fun (Item_t (c, t)) -> + aux s w >>? fun [@coq_match_with_default] (Item_t (c, t)) -> pair_t dummy a c >|? fun (Ty_ex_c p) -> Item_t (p, t) in aux s p >|? fun s -> @@ -1468,7 +1474,7 @@ let kinstr_split : (a, b, s, c, d, t) uncomb_gadt_witness -> (c, d * t) stack_ty = fun s w -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | Uncomb_one, s -> s | Uncomb_succ w, Item_t (Pair_t (a, b, _meta, _), s) -> let s = aux (Item_t (b, s)) w in @@ -1486,7 +1492,7 @@ let kinstr_split : let rec aux : type c cc a. (c, cc) ty -> (c, a) comb_get_gadt_witness -> a ty_ex_c = fun c w -> - match (w, c) with + match[@coq_match_with_default] (w, c) with | Comb_get_zero, c -> Ty_ex_c c | Comb_get_one, Pair_t (hd, _tl, _meta, _) -> Ty_ex_c hd | Comb_get_plus_two w, Pair_t (_hd, tl, _meta, _) -> aux tl w @@ -1510,7 +1516,7 @@ let kinstr_split : (a, b, c) comb_set_gadt_witness -> c ty_ex_c tzresult = fun a b w -> - match (w, b) with + match[@coq_match_with_default] (w, b) with | Comb_set_zero, _ -> ok (Ty_ex_c a) | Comb_set_one, Pair_t (_hd, tl, _meta, _) -> pair_t dummy a tl | Comb_set_plus_two w, Pair_t (hd, tl, _meta, _) -> @@ -1529,7 +1535,7 @@ let kinstr_split : type a b s t. (a, b * s) stack_ty -> (a, b, s, t) dup_n_gadt_witness -> t ty_ex_c = fun s w -> - match (w, s) with + match[@coq_match_with_default] (w, s) with | Dup_n_succ w, Item_t (_, s) -> aux s w | Dup_n_zero, Item_t (a, _) -> Ty_ex_c a in @@ -1629,7 +1635,7 @@ let kinstr_split : reconstruct = (fun k -> ILog (loc, s, event, logger, k)); } -let rec kinstr_final_stack_type : +let[@coq_struct "i_value"] rec kinstr_final_stack_type : type a s r f. (a, s) stack_ty -> (a, s, r, f) kinstr -> (r, f) stack_ty option tzresult = fun s i -> @@ -1792,17 +1798,19 @@ let log_next_continuation : kinstr_final_stack_type stack_ty ki >|? function | None -> KCons (ki', k) | Some sty -> KCons (ki', instrument_cont logger sty k)) - | KLoop_in (ki, k) -> - let (Item_t (Bool_t, sty)) = stack_ty in - ok @@ KLoop_in (enable_log sty ki, instrument_cont logger sty k) + | KLoop_in (ki, k) -> ( + match[@coq_match_with_default] stack_ty with + | Item_t (Bool_t, sty) -> + ok @@ KLoop_in (enable_log sty ki, instrument_cont logger sty k)) | KReturn (stack, sty, k) -> let k' = instrument_cont logger (assert_some sty) k in ok @@ KReturn (stack, sty, k') - | KLoop_in_left (ki, k) -> - let (Item_t (Union_t (a_ty, b_ty, _, _), rest)) = stack_ty in - let ki' = enable_log (Item_t (a_ty, rest)) ki in - let k' = instrument_cont logger (Item_t (b_ty, rest)) k in - ok @@ KLoop_in_left (ki', k') + | KLoop_in_left (ki, k) -> ( + match[@coq_match_with_default] stack_ty with + | Item_t (Union_t (a_ty, b_ty, _, _), rest) -> + let ki' = enable_log (Item_t (a_ty, rest)) ki in + let k' = instrument_cont logger (Item_t (b_ty, rest)) k in + ok @@ KLoop_in_left (ki', k')) | KUndip (x, ty, k) -> let k' = instrument_cont logger (Item_t (assert_some ty, stack_ty)) k in ok @@ KUndip (x, ty, k') @@ -1813,17 +1821,19 @@ let log_next_continuation : | KList_enter_body (body, xs, ys, ty, len, k) -> let k' = instrument_cont logger (Item_t (assert_some ty, stack_ty)) k in ok @@ KList_enter_body (body, xs, ys, ty, len, k') - | KList_exit_body (body, xs, ys, ty, len, k) -> - let (Item_t (_, sty)) = stack_ty in - let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in - ok @@ KList_exit_body (body, xs, ys, ty, len, k') + | KList_exit_body (body, xs, ys, ty, len, k) -> ( + match[@coq_match_with_default] stack_ty with + | Item_t (_, sty) -> + let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in + ok @@ KList_exit_body (body, xs, ys, ty, len, k')) | KMap_enter_body (body, xs, ys, ty, k) -> let k' = instrument_cont logger (Item_t (assert_some ty, stack_ty)) k in ok @@ KMap_enter_body (body, xs, ys, ty, k') - | KMap_exit_body (body, xs, ys, yk, ty, k) -> - let (Item_t (_, sty)) = stack_ty in - let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in - ok @@ KMap_exit_body (body, xs, ys, yk, ty, k') + | KMap_exit_body (body, xs, ys, yk, ty, k) -> ( + match[@coq_match_with_default] stack_ty with + | Item_t (_, sty) -> + let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in + ok @@ KMap_exit_body (body, xs, ys, yk, ty, k')) | KMap_head (_, _) | KView_exit (_, _) | KLog _ (* This case should never happen. *) | KNil -> @@ -1835,6 +1845,6 @@ let rec dipn_stack_ty : (c, u) stack_ty -> (a, s) stack_ty = fun witness stack -> - match (witness, stack) with + match[@coq_match_with_default] (witness, stack) with | KPrefix (_, _, witness'), Item_t (_, sty) -> dipn_stack_ty witness' sty | KRest, sty -> sty diff --git a/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.mli b/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.mli index f2e26a0cef56e..7cfd10edc4824 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.mli +++ b/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.mli @@ -33,6 +33,7 @@ type ('r, 'f) ex_init_stack_ty = | Ex_init_stack_ty : ('a, 's) stack_ty * ('a, 's, 'r, 'f) kinstr -> ('r, 'f) ex_init_stack_ty +[@@coq_force_gadt] (** [log_kinstr logger sty instr] returns [instr] prefixed by an [ILog] instruction to log the first instruction in [instr]. Note diff --git a/src/proto_015_PtLimaPt/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/operations/test_combined_operations.ml index 9a02d86732945..60e7ca767fb6a 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -118,7 +118,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 @@ -186,7 +187,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 @@ -231,7 +233,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_015_PtLimaPt/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/operations/test_tx_rollup.ml index 640a74bf1bd53..9eef95652ef73 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -3018,7 +3018,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"); })) @@ -4666,7 +4666,7 @@ module Withdraw = struct ~expect_apply_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 @@ -4687,7 +4687,7 @@ module Withdraw = struct ~expect_apply_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 @@ -4729,7 +4729,7 @@ module Withdraw = struct ~expect_apply_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 @@ -4750,7 +4750,7 @@ module Withdraw = struct ~expect_apply_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 @@ -5039,7 +5039,7 @@ module Withdraw = struct ~expect_apply_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 @@ -5060,7 +5060,7 @@ module Withdraw = struct ~expect_apply_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 @@ -5083,7 +5083,7 @@ module Withdraw = struct ~expect_apply_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_015_PtLimaPt/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/test_frozen_bonds.ml index aca5cf883269f..02541344050c5 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_015_PtLimaPt/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, _ = Tezos_crypto.Signature.generate_key () in let delegate_contract = Contract.Implicit delegate in - let delegate_account = `Contract (Contract.Implicit 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, _, _ = Tezos_crypto.Signature.generate_key () in Contract.Implicit 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_015_PtLimaPt/lib_protocol/test/integration/test_token.ml b/src/proto_015_PtLimaPt/lib_protocol/test/integration/test_token.ml index f828639aae7d8..3b087fbdff85c 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/integration/test_token.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/test/integration/test_token.ml @@ -61,11 +61,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 pkh) in + let src = Token.Contract (Contract.Implicit pkh) in let pkh, _pk, _sk = Tezos_crypto.Signature.generate_key () in - let dest = `Contract (Contract.Implicit pkh) in + let dest = Token.Contract (Contract.Implicit 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) -> @@ -84,7 +85,12 @@ let test_simple_balance_updates () = let pkh, _pk, _sk = Tezos_crypto.Signature.generate_key () in let dest = Contract.Implicit 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 @@ -110,11 +116,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 @@ -128,20 +142,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 = Tezos_crypto.Signature.generate_key () in - let dest = `Contract (Contract.Implicit pkh) in + let dest = Token.Contract (Contract.Implicit 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 pkh, bond_id) + Token.Frozen_bonds (Contract.Implicit pkh, bond_id) in test_allocated_and_deallocated_when_empty ctxt dest @@ -156,20 +170,29 @@ 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 pkh) in - wrap (Token.transfer ctxt `Minted account Tez.one_mutez) >|=? fst + | Token.Delegate_balance pkh -> + let account = Token.Sink_container (Contract (Contract.Implicit 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 @@ -179,7 +202,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 = @@ -188,7 +213,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)] @@ -197,7 +222,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)] @@ -207,7 +232,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)] @@ -216,7 +241,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)] @@ -224,26 +249,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__ @@ -257,7 +295,11 @@ let test_transferring_to_burned ctxt = let pkh = Tezos_crypto.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__ @@ -287,7 +329,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)] @@ -310,11 +352,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)] @@ -333,48 +377,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 @@ -385,7 +457,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)] @@ -394,7 +466,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)] @@ -404,7 +476,7 @@ let test_transferring_from_delegate_balance ctxt = let src = Contract.Implicit pkh in test_transferring_from_bounded_source ctxt - (`Delegate_balance pkh) + (Delegate_balance pkh) amount [(Contract src, Debited amount, Block_application)] @@ -413,7 +485,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)] @@ -421,7 +493,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)] @@ -433,46 +505,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 _ -> @@ -496,23 +584,23 @@ 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 pkh) in + let origin = Token.Contract (Contract.Implicit pkh) in let user1, _, _ = Tezos_crypto.Signature.generate_key () in - let user1c = `Contract (Contract.Implicit user1) in + let user1c = Token.Contract (Contract.Implicit user1) in let user2, _, _ = Tezos_crypto.Signature.generate_key () in - let user2c = `Contract (Contract.Implicit user2) in + let user2c = Token.Contract (Contract.Implicit user2) in let baker1, baker1_pk, _ = Tezos_crypto.Signature.generate_key () in - let baker1c = `Contract (Contract.Implicit baker1) in + let baker1c = Token.Contract (Contract.Implicit baker1) in let baker2, baker2_pk, _ = Tezos_crypto.Signature.generate_key () in - let baker2c = `Contract (Contract.Implicit baker2) in + let baker2c = Token.Contract (Contract.Implicit 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. *) @@ -533,81 +621,83 @@ let build_test_cases () = let baker2ic = Contract.Implicit 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 (Contract.Implicit c) as contract) ) - | ( Some (`Contract (Contract.Implicit c) as contract), - Some (`Delegate_balance d) ) + | ( Some (Source_container (Delegate_balance d)), + Some (Sink_container (Contract (Contract.Implicit c) as contract)) ) + | ( Some (Source_container (Contract (Contract.Implicit c) as contract)), + Some (Sink_container (Delegate_balance d)) ) when 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) @@ -642,15 +732,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 = @@ -659,29 +754,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. *) @@ -692,46 +787,54 @@ 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 pkh) in + let origin = Token.Contract (Contract.Implicit pkh) in let user1, _, _ = Tezos_crypto.Signature.generate_key () in - let user1c = `Contract (Contract.Implicit user1) in + let user1c = Token.Contract (Contract.Implicit user1) in let user2, _, _ = Tezos_crypto.Signature.generate_key () in - let user2c = `Contract (Contract.Implicit user2) in + let user2c = Token.Contract (Contract.Implicit user2) in let user3, _, _ = Tezos_crypto.Signature.generate_key () in - let user3c = `Contract (Contract.Implicit user3) in + let user3c = Token.Contract (Contract.Implicit user3) in let user4, _, _ = Tezos_crypto.Signature.generate_key () in - let user4c = `Contract (Contract.Implicit user4) in + let user4c = Token.Contract (Contract.Implicit 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_015_PtLimaPt/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_015_PtLimaPt/lib_protocol/test/unit/test_tx_rollup_l2.ml index a2368b23c1869..86d09164897f0 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/test/unit/test_tx_rollup_l2.ml +++ b/src/proto_015_PtLimaPt/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_015_PtLimaPt/lib_protocol/tx_rollup_ticket.ml b/src/proto_015_PtLimaPt/lib_protocol/tx_rollup_ticket.ml index d2d6e06c0afff..8ffb1741f6bd7 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/tx_rollup_ticket.ml +++ b/src/proto_015_PtLimaPt/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_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index c69ecf57225f7..ada40d0a5e3ca 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -1314,7 +1314,7 @@ let sc_rollup_originate (cctxt : #full) ~chain ~block ?confirmations ?dry_run >>= fun origination_proof -> let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in let origination_proof = - Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof + Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof_val in let op = Annotated_manager_operation.Single_manager diff --git a/src/proto_alpha/lib_client/client_proto_rollups.ml b/src/proto_alpha/lib_client/client_proto_rollups.ml index f41391a9c48c2..57811933201b4 100644 --- a/src/proto_alpha/lib_client/client_proto_rollups.ml +++ b/src/proto_alpha/lib_client/client_proto_rollups.ml @@ -161,7 +161,7 @@ module ScRollup = struct (module struct include Arith_pvm - let proof = proof + let proof_val = proof end)) | Sc_rollup.Kind.Wasm_2_0_0 -> let open Lwt_result_syntax in @@ -172,7 +172,7 @@ module ScRollup = struct (module struct include Wasm_pvm - let proof = proof + let proof_val = proof end)) in let open Lwt_syntax in diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index 21b58428d339f..4a53ecbd03003 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -115,7 +115,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) @@ -124,7 +124,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:Tezos_crypto.Block_hash.t -> @@ -136,7 +136,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_alpha/lib_injector/injector_functor.ml b/src/proto_alpha/lib_injector/injector_functor.ml index cd686719c0c9d..3bad25dd55275 100644 --- a/src/proto_alpha/lib_injector/injector_functor.ml +++ b/src/proto_alpha/lib_injector/injector_functor.ml @@ -553,7 +553,7 @@ module Make (Rollup : PARAMETERS) = struct trace (Step_failed "simulation") @@ 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_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 29dd4b57827e2..3c6682170db8b 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -54,7 +54,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 = @@ -64,7 +64,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) @@ -79,7 +80,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 = @@ -92,7 +93,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 = @@ -102,7 +103,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 = @@ -118,7 +119,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 = @@ -944,8 +945,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_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 9bc93ba4fbd60..f0b2360890c1a 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -210,7 +210,6 @@ end module Round = struct include Round_repr - module Durations = Durations type round_durations = Durations.t @@ -405,7 +404,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 @@ -455,7 +459,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_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 17aae84fb4115..6be83e3ce89cf 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -107,9 +107,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 @@ -221,7 +221,7 @@ end (** This module re-exports definitions from {!Raw_level_repr}. *) module Raw_level : sig - include BASIC_DATA + include BASIC_DATA with type t = Raw_level_repr.t type raw_level = t @@ -372,6 +372,7 @@ module Gas : sig module Arith : Fixed_point_repr.Safe with type 'a t = private Saturation_repr.may_saturate Saturation_repr.t + [@@coq_plain_module] (** For maintenance operations or for testing, gas can be [Unaccounted]. Otherwise, the computation is [Limited] by the @@ -1358,7 +1359,7 @@ module Big_map : sig (** The type of big map updates. When [value = None], the potential binding associated to the [key] will be removed. *) - type update = { + type update = Lazy_storage_kind.Big_map.update = { key : Script_repr.expr; (** The key is ignored by an update but is shown in the receipt. *) key_hash : Script_expr_hash.t; @@ -1368,7 +1369,10 @@ module Big_map : sig type updates = update list (** The types of keys and values in a big map. *) - 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} @@ -1399,7 +1403,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 @@ -1455,7 +1459,7 @@ module Sapling : sig (context * (Int64.t * state) option) tzresult Lwt.t (** See {!Lazy_storage_kind.Sapling_state.alloc}. *) - type alloc = {memo_size : Memo_size.t} + type alloc = Lazy_storage_kind.Sapling_state.alloc = {memo_size : Memo_size.t} type updates = diff @@ -1555,7 +1559,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 @@ -1625,7 +1629,9 @@ end (** This module re-exports definitions from {!Contract_repr} and {!Contract_storage}. *) module Contract : sig - type t = Implicit of public_key_hash | Originated of Contract_hash.t + type t = Contract_repr.t = + | Implicit of public_key_hash + | Originated of Contract_hash.t (** Functions related to contracts address. *) @@ -1816,7 +1822,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 in_memory_size : t -> Cache_memory_helpers.sint @@ -1856,11 +1862,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 @@ -2006,7 +2013,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; @@ -2154,11 +2161,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 @@ -2256,6 +2266,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 @@ -2293,7 +2309,7 @@ module Tx_rollup_errors : sig length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -2312,9 +2328,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; } | Proof_undecodable | Proof_failed_to_reject @@ -2326,7 +2340,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. @@ -2334,14 +2348,18 @@ 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 + + module State_hash : sig + type t = Sc_rollup_repr.State_hash.t + end 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 @@ -2365,7 +2383,7 @@ end (** This module re-exports definitions from {!Zk_rollup_repr} and {!Zk_rollup_storage}. *) module Zk_rollup : sig - module Address : S.HASH + module Address : S.HASH [@@coq_plain_module] type t = Address.t @@ -2424,6 +2442,7 @@ module Zk_rollup : sig val encoding : t Data_encoding.t end + [@@coq_plain_module] module Circuit_public_inputs : sig type pending_op_public_inputs = { @@ -2592,13 +2611,13 @@ end (** This module re-exports definitions from {!Delegate_consensus_key}. *) module Consensus_key : sig - type pk = { + type pk = Delegate_consensus_key.pk = { delegate : Signature.Public_key_hash.t; consensus_pk : Signature.Public_key.t; consensus_pkh : Signature.Public_key_hash.t; } - type t = { + type t = Delegate_consensus_key.t = { delegate : Signature.Public_key_hash.t; consensus_pkh : Signature.Public_key_hash.t; } @@ -2689,7 +2708,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 @@ -2895,7 +2917,7 @@ module Dal : sig (** This module re-exports definitions from {!Dal_slot_repr.Index}. *) module Slot_index : sig - type t + type t = Dal_slot_repr.Index.t val pp : Format.formatter -> t -> unit @@ -2955,7 +2977,10 @@ module Dal : sig val init_committee : context -> committee -> context end - type slot_id = {published_level : Raw_level.t; index : Slot_index.t} + type slot_id = Dal_slot_repr.Header.id = { + published_level : Raw_level.t; + index : Slot_index.t; + } module Page : sig type content = bytes @@ -2974,7 +2999,7 @@ module Dal : sig val equal : int -> int -> bool end - type t = {slot_id : slot_id; page_index : Index.t} + type t = Dal_slot_repr.Page.t = {slot_id : slot_id; page_index : Index.t} val content_encoding : content Data_encoding.t @@ -3099,7 +3124,7 @@ end module Sc_rollup : sig (** See {!Sc_rollup_tick_repr}. *) module Tick : sig - type t + type t = Sc_rollup_tick_repr.t val initial : t @@ -3122,7 +3147,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 @@ -3133,7 +3158,7 @@ module Sc_rollup : sig module Staker : S.SIGNATURE_PUBLIC_KEY_HASH with type t = public_key_hash module State_hash : sig - include S.HASH + include S.HASH with type t = Sc_rollup_repr.State_hash.t val context_hash_to_state_hash : Context_hash.t -> t @@ -3146,7 +3171,10 @@ module Sc_rollup : sig (** See {!Sc_rollup_metadata_repr}. *) module Metadata : sig - type t = {address : rollup; origination_level : Raw_level.t} + type t = Sc_rollup_metadata_repr.t = { + address : rollup; + origination_level : Raw_level.t; + } val pp : Format.formatter -> t -> unit @@ -3170,7 +3198,7 @@ module Sc_rollup : sig type t = Internal of internal_inbox_message | External of string - type serialized + type serialized = Sc_rollup_inbox_message_repr.serialized val encoding : t Data_encoding.t @@ -3236,18 +3264,20 @@ module Sc_rollup : sig end end - type inbox_message = { + type inbox_message = Sc_rollup_PVM_sig.inbox_message = { inbox_level : Raw_level.t; message_counter : Z.t; payload : Inbox_message.serialized; } - type reveal_data = + type reveal_data = Sc_rollup_PVM_sig.reveal_data = | Raw_data of string | Metadata of Metadata.t | Dal_page of Dal.Page.content option - type input = Inbox_message of inbox_message | Reveal of reveal_data + type input = Sc_rollup_PVM_sig.input = + | Inbox_message of inbox_message + | Reveal of reveal_data val pp_inbox_message : Format.formatter -> inbox_message -> unit @@ -3259,16 +3289,16 @@ module Sc_rollup : sig val input_encoding : input Data_encoding.t - module Input_hash : S.HASH + module Input_hash : S.HASH with type t = Sc_rollup_PVM_sig.Input_hash.t - module Reveal_hash : S.HASH + module Reveal_hash : S.HASH with type t = Sc_rollup_PVM_sig.Reveal_hash.t - type reveal = + type reveal = Sc_rollup_PVM_sig.reveal = | Reveal_raw_data of Reveal_hash.t | Reveal_metadata | Request_dal_page of Dal.Page.t - type input_request = + type input_request = Sc_rollup_PVM_sig.input_request = | No_input_required | Initial | First_after of Raw_level.t * Z.t @@ -3410,13 +3440,14 @@ module Sc_rollup : sig module Outbox : sig (** See {!Sc_rollup_outbox_message_repr}. *) module Message : sig - type transaction = { + type transaction = Sc_rollup_outbox_message_repr.transaction = { unparsed_parameters : Script.expr; destination : Contract_hash.t; entrypoint : Entrypoint.t; } - type t = Atomic_transaction_batch of {transactions : transaction list} + type t = Sc_rollup_outbox_message_repr.t = + | Atomic_transaction_batch of {transactions : transaction list} type serialized @@ -3437,7 +3468,7 @@ module Sc_rollup : sig (Z.t * context) tzresult Lwt.t end - type output = { + type output = Sc_rollup_PVM_sig.output = { outbox_level : Raw_level.t; message_index : Z.t; message : Outbox.Message.t; @@ -3565,6 +3596,7 @@ module Sc_rollup : sig val all_names : string list end + [@@coq_plain_module] module ArithPVM : sig module type P = sig @@ -3618,7 +3650,7 @@ module Sc_rollup : sig val reference_initial_state_hash : State_hash.t module Protocol_implementation : - PVM.S + Sc_rollup_arith.S with type context = Context.t and type state = Context.tree and type proof = Context.Proof.tree Context.Proof.t @@ -3649,9 +3681,13 @@ module Sc_rollup : sig (proof * 'a) option Lwt.t end - module type Make_wasm = module type of Wasm_2_0_0.Make - - module Make (Wasm_backend : Make_wasm) (C : P) : sig + module Make + (Wasm_backend : functor + (Tree : Context.TREE + with type key = string list + and type value = bytes) + -> Wasm_2_0_0.S with type tree := Tree.tree) + (C : P) : sig include PVM.S with type context = C.Tree.t @@ -3674,7 +3710,7 @@ module Sc_rollup : sig end module Protocol_implementation : - PVM.S + Sc_rollup_wasm.V2_0_0.S with type context = Context.t and type state = Context.tree and type proof = Context.Proof.tree Context.Proof.t @@ -3689,7 +3725,7 @@ module Sc_rollup : sig end module Commitment : sig - module Hash : S.HASH + module Hash : S.HASH [@@coq_plain_module] type t = { compressed_state : State_hash.t; @@ -3744,7 +3780,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 = @@ -3787,8 +3823,6 @@ module Sc_rollup : sig val state : state - val proof_encoding : proof Data_encoding.t - val reveal : Reveal_hash.t -> string option Lwt.t module Inbox_with_history : sig @@ -4409,12 +4443,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; @@ -4689,10 +4724,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_attestation of Chain_id.t + module Consensus_watermark : sig + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_attestation of Chain_id.t + end + + open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark @@ -5156,36 +5195,40 @@ 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 public_key_hash - | `Frozen_deposits of public_key_hash - | `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 + | Sc_rollup_refutation_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 - | `Sc_rollup_refutation_rewards - | container ] - - type sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of public_key_hash * 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 @@ -5194,15 +5237,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_alpha/lib_protocol/amendment.ml b/src/proto_alpha/lib_protocol/amendment.ml index 6fd95d922bf52..64bc8c852cd5f 100644 --- a/src/proto_alpha/lib_protocol/amendment.ml +++ b/src/proto_alpha/lib_protocol/amendment.ml @@ -190,7 +190,10 @@ let apply_testnet_dictator_proposals ctxt chain_id proposals = previously validated by {!Validate.validate_operation}. *) tzfail Validate_errors.Voting.Testnet_dictator_multiple_proposals -let apply_proposals ctxt chain_id (Proposals {source; period = _; proposals}) = +let apply_proposals ctxt chain_id contents = + let[@coq_match_with_default] (Proposals {source; period = _; proposals}) = + contents + in let open Lwt_result_syntax in let* ctxt = if is_testnet_dictator ctxt chain_id source then @@ -212,7 +215,11 @@ let apply_proposals ctxt chain_id (Proposals {source; period = _; proposals}) = in return (ctxt, Apply_results.Single_result Proposals_result) -let apply_ballot ctxt (Ballot {source; period = _; proposal = _; ballot}) = +let apply_ballot ctxt contents = + let[@coq_match_with_default] (Ballot + {source; period = _; proposal = _; ballot}) = + contents + in let open Lwt_result_syntax in let* ctxt = if dictator_proposal_seen ctxt then (* Noop if dictator voted *) return ctxt diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index b8a206cb4fbef..7b1193e843e09 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -289,7 +289,7 @@ let apply_delegation ~ctxt ~source ~delegate ~before_operation = type 'loc execution_arg = | Typed_arg : 'loc * ('a, _) Script_typed_ir.ty * 'a -> 'loc execution_arg - | Untyped_arg : Script.expr -> _ execution_arg + | Untyped_arg : Script.expr -> 'loc execution_arg let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~before_operation = let contract = Contract.Implicit pkh in @@ -298,7 +298,11 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~before_operation = (* 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 result = Transaction_to_contract_result @@ -325,7 +329,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 @@ -353,7 +361,7 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount } in let execute = - match parameter with + match[@coq_match_gadt] parameter with | Untyped_arg parameter -> Script_interpreter.execute ~parameter | Typed_arg (location, parameter_ty, parameter) -> Script_interpreter.execute_with_typed_parameter @@ -466,7 +474,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) -> @@ -519,7 +531,11 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code | None -> return ctxt | Some delegate -> Contract.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_hash >|=? fun (ctxt, size, paid_storage_size_diff) -> @@ -831,7 +847,7 @@ let apply_manager_operation : 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 -> @@ -1053,7 +1069,9 @@ let apply_manager_operation : | Increase_paid_storage {amount_in_bytes; destination} -> Contract.increase_paid_storage ctxt destination ~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 = @@ -1096,7 +1114,11 @@ let apply_manager_operation : >>=? 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 = @@ -1116,8 +1138,8 @@ let apply_manager_operation : 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) -> @@ -1130,12 +1152,12 @@ let apply_manager_operation : >>=? 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, [])) @@ -1152,12 +1174,12 @@ let apply_manager_operation : | 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 = @@ -1276,19 +1298,19 @@ let apply_manager_operation : (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) @@ -1436,7 +1458,7 @@ let apply_manager_operation : type success_or_failure = Success of context | Failure let apply_internal_operations ctxt ~payer ~chain_id ops = - let rec apply ctxt applied worklist = + let[@coq_struct "ctxt"] rec apply ctxt applied worklist = match worklist with | [] -> Lwt.return (Success ctxt, List.rev applied) | Script_typed_ir.Internal_operation ({source; operation; nonce} as op) @@ -1565,7 +1587,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 @@ -1704,7 +1726,7 @@ let burn_internal_storage_fees : payer:public_key_hash -> (context * Z.t * kind successful_internal_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 @@ -1731,7 +1753,14 @@ let apply_manager_contents (type kind) ctxt chain_id * kind manager_operation_result * packed_internal_operation_result list) Lwt.t = - let (Manager_operation {source; operation; gas_limit; storage_limit; _}) = + let[@coq_match_with_default] (Manager_operation + { + source; + operation; + gas_limit; + storage_limit; + _; + }) = op in (* We do not expose the internal scaling to the users. Instead, we multiply @@ -1811,7 +1840,7 @@ let rec mark_skipped : kind Kind.manager fees_updated_contents_list -> kind Kind.manager contents_result_list = fun ~payload_producer level fees_updated_contents_list -> - match fees_updated_contents_list with + match[@coq_match_with_default] fees_updated_contents_list with | FeesUpdatedSingle {contents = Manager_operation {operation; _}; balance_updates} -> Single_result @@ -1855,14 +1884,17 @@ let take_fees ctxt contents_list = (context * kind Kind.manager fees_updated_contents_list) tzresult Lwt.t = fun ctxt contents_list -> let contents_effects contents = - let (Manager_operation {source; fee; gas_limit; _}) = contents in + let[@coq_match_with_default] (Manager_operation + {source; fee; gas_limit; _}) = + contents + in let*? ctxt = Gas.consume_limit_in_block ctxt gas_limit in let* ctxt = Contract.increment_counter ctxt source in 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}) @@ -1888,7 +1920,7 @@ let rec apply_manager_contents_list_rec : (success_or_failure * kind Kind.manager contents_result_list) Lwt.t = fun ctxt ~payload_producer chain_id fees_updated_contents_list -> let level = Level.current ctxt in - match fees_updated_contents_list with + match[@coq_match_with_default] fees_updated_contents_list with | FeesUpdatedSingle {contents = Manager_operation _ as op; balance_updates} -> apply_manager_contents ctxt chain_id op >|= fun (ctxt_result, operation_result, internal_operation_results) -> @@ -1940,7 +1972,7 @@ let mark_backtracked results = (Internal_operation_result (kind, result)) = Internal_operation_result (kind, mark_internal_operation_result result) in - match results with + match[@coq_match_with_default] results with | Manager_operation_result op -> Manager_operation_result { @@ -1998,7 +2030,7 @@ type application_state = { 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_attestation _) -> ctxt @@ -2110,19 +2142,22 @@ let apply_manager_operations ctxt ~payload_producer chain_id ~mempool_mode in return (ctxt, contents_result_list) +type mistake = Double_baking | Double_endorsing + let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = let punish = match mistake with - | `Double_baking -> Delegate.punish_double_baking - | `Double_endorsing -> Delegate.punish_double_endorsing + | Double_baking -> Delegate.punish_double_baking + | Double_endorsing -> Delegate.punish_double_endorsing in punish ctxt delegate level >>=? fun (ctxt, burned, punish_balance_updates) -> (match Tez.(burned /? 2L) with | Ok reward -> Token.transfer ctxt - `Double_signing_evidence_rewards - (`Contract (Contract.Implicit payload_producer.Consensus_key.delegate)) + (Source_infinite Double_signing_evidence_rewards) + (Sink_container + (Contract (Contract.Implicit payload_producer.Consensus_key.delegate))) reward | Error _ -> (* reward is Tez.zero *) return (ctxt, [])) >|=? fun (ctxt, reward_balance_updates) -> @@ -2137,13 +2172,13 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt 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 with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement e1) | Single (Endorsement e1) -> let level = Level.from_raw ctxt e1.level in Stake_distribution.slot_owner ctxt level e1.slot @@ -2152,7 +2187,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ctxt consensus_pk1.delegate level - `Double_endorsing + Double_endorsing mk_result ~payload_producer @@ -2169,7 +2204,7 @@ let punish_double_baking ctxt (bh1 : Block_header.t) ~payload_producer = ctxt consensus_pk1.delegate level - `Double_baking + Double_baking ~payload_producer (fun balance_updates -> Double_baking_evidence_result balance_updates) @@ -2181,7 +2216,7 @@ let apply_contents_list (type kind) ctxt chain_id (mode : mode) | Partial_construction _ -> true | Full_construction _ | Application _ -> false in - match contents_list with + match[@coq_match_with_default] contents_list with | Single (Preendorsement consensus_content) -> record_preendorsement ctxt mode consensus_content |> Lwt.return | Single (Endorsement consensus_content) -> @@ -2207,7 +2242,11 @@ let apply_contents_list (type kind) ctxt chain_id (mode : mode) let contract = Contract.Implicit payload_producer.Consensus_key.delegate 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}) -> @@ -2216,7 +2255,11 @@ let apply_contents_list (type kind) ctxt chain_id (mode : mode) let contract = Contract.Implicit payload_producer.Consensus_key.delegate 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 = _}) -> @@ -2229,10 +2272,14 @@ let apply_contents_list (type kind) ctxt chain_id (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 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 _ as contents) -> @@ -2246,8 +2293,9 @@ let apply_contents_list (type kind) ctxt chain_id (mode : mode) drain_balance_updates ) -> Token.transfer ctxt - (`Contract (Contract.Implicit delegate)) - (`Contract (Contract.Implicit payload_producer.Consensus_key.delegate)) + (Source_container (Contract (Contract.Implicit delegate))) + (Sink_container + (Contract (Contract.Implicit payload_producer.Consensus_key.delegate))) fees >>=? fun (ctxt, fees_balance_updates) -> let balance_updates = drain_balance_updates @ fees_balance_updates in @@ -2349,8 +2397,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_alpha/lib_protocol/apply_internal_results.ml b/src/proto_alpha/lib_protocol/apply_internal_results.ml index 7986c5877950a..1d82c6261a079 100644 --- a/src/proto_alpha/lib_protocol/apply_internal_results.ml +++ b/src/proto_alpha/lib_protocol/apply_internal_results.ml @@ -228,6 +228,7 @@ module Internal_operation = struct inj : 'a -> 'kind internal_operation_contents; } -> 'kind case + [@@coq_force_gadt] let transaction_contract_variant_cases = union @@ -365,7 +366,7 @@ module Internal_operation = struct | Internal_operation_contents (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -408,7 +409,7 @@ module Internal_operation = struct | Internal_operation_contents (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) -> @@ -433,7 +434,7 @@ module Internal_operation = struct (function | Internal_operation_contents (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); } @@ -458,7 +459,7 @@ module Internal_operation = struct (function | Internal_operation_contents (Event _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Event {ty; tag; payload} -> let tag = if Entrypoint.is_default tag then None else Some tag in let payload = @@ -481,13 +482,16 @@ module Internal_operation = 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 -> Internal_operation_contents (inj x)) + let make mcase = + match[@coq_match_gadt] mcase 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 -> Internal_operation_contents (inj x)) in union ~tag_size:`Uint8 @@ -587,7 +591,7 @@ module Internal_operation_result = struct Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function ITransaction_result x -> x) + ~proj:(function[@coq_match_with_default] ITransaction_result x -> x) ~inj:(fun x -> ITransaction_result x) let origination_case = @@ -605,7 +609,7 @@ module Internal_operation_result = struct | Successful_internal_operation_result (IOrigination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | IOrigination_result { lazy_storage_diff; @@ -655,7 +659,8 @@ module Internal_operation_result = struct Some op | _ -> None) ~kind:Kind.Delegation_manager_kind - ~proj:(function IDelegation_result {consumed_gas} -> consumed_gas) + ~proj:(function[@coq_match_with_default] + | IDelegation_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> IDelegation_result {consumed_gas}) let event_case = @@ -669,7 +674,8 @@ module Internal_operation_result = struct Some op | _ -> None) ~kind:Kind.Event_manager_kind - ~proj:(function IEvent_result {consumed_gas} -> consumed_gas) + ~proj:(function[@coq_match_with_default] + | IEvent_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> IEvent_result {consumed_gas}) end @@ -678,25 +684,28 @@ let internal_operation_result_encoding : let make (type kind) (Internal_operation_result.MCase res_case : kind Internal_operation_result.case) - (Internal_operation.MCase ires_case : kind Internal_operation.case) = - let (Internal_operation.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_operation_result (op, res)) + (ires_mcase : kind Internal_operation.case) = + match[@coq_match_gadt] ires_mcase with + | Internal_operation.MCase ires_case -> + let (Internal_operation.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_operation_result (op, res)) in def "apply_internal_results.alpha.operation_result" @@ union diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.ml b/src/proto_alpha/lib_protocol/apply_operation_result.ml index d5763a4a80500..2a57cf4781f3d 100644 --- a/src/proto_alpha/lib_protocol/apply_operation_result.ml +++ b/src/proto_alpha/lib_protocol/apply_operation_result.ml @@ -25,7 +25,7 @@ open Data_encoding -type ('kind, 'manager, 'successful) operation_result = +type (_, 'manager, 'successful) operation_result = | Applied of 'successful | Backtracked of 'successful * error trace option | Failed : diff --git a/src/proto_alpha/lib_protocol/apply_operation_result.mli b/src/proto_alpha/lib_protocol/apply_operation_result.mli index e48842e3ca719..914666661d867 100644 --- a/src/proto_alpha/lib_protocol/apply_operation_result.mli +++ b/src/proto_alpha/lib_protocol/apply_operation_result.mli @@ -32,7 +32,7 @@ The ['kind] parameter is used to make the type a GADT, but ['manager] and ['successful] are used to share [operation_result] between internal and external operation results, and are instantiated for each case. *) -type ('kind, 'manager, 'successful) operation_result = +type (_, 'manager, 'successful) operation_result = | Applied of 'successful | Backtracked of 'successful * error trace option | Failed : diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index a8d57c5329e78..9188970eb4f4d 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -257,7 +257,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 @@ -287,7 +287,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 @@ -308,7 +308,8 @@ 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 transaction_contract_variant_cases = @@ -428,7 +429,7 @@ 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 origination_case = @@ -445,7 +446,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; @@ -498,7 +499,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)) @@ -518,7 +519,8 @@ module Manager_result = struct | Successful_manager_result (Delegation_result _ as op) -> Some op | _ -> None) ~kind:Kind.Delegation_manager_kind - ~proj:(function Delegation_result {consumed_gas} -> consumed_gas) + ~proj:(function[@coq_match_with_default] + | Delegation_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> Delegation_result {consumed_gas}) let update_consensus_key_case = @@ -532,7 +534,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Update_consensus_key_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Update_consensus_key_result {consumed_gas} -> consumed_gas) ~inj:(fun consumed_gas -> Update_consensus_key_result {consumed_gas}) @@ -547,7 +549,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}) @@ -564,7 +566,7 @@ 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) -> @@ -584,7 +586,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)) @@ -606,7 +608,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)) @@ -626,7 +628,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, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> @@ -645,7 +647,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, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> @@ -667,7 +669,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)) @@ -691,7 +693,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)) @@ -712,7 +714,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, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> @@ -734,7 +736,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)) @@ -755,7 +757,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)) @@ -773,7 +775,7 @@ 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}) @@ -793,7 +795,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Zk_rollup_origination_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Zk_rollup_origination_result {balance_updates; originated_zk_rollup; consumed_gas; storage_size} -> @@ -817,7 +819,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Zk_rollup_publish_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Zk_rollup_publish_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -860,7 +862,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; @@ -901,7 +903,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 @@ -918,7 +920,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; inbox_level} -> (consumed_gas, inbox_level)) ~kind:Kind.Sc_rollup_cement_manager_kind @@ -938,7 +940,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)) @@ -960,7 +962,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; game_status; balance_updates} -> (consumed_gas, game_status, balance_updates)) @@ -980,7 +982,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; game_status; balance_updates} -> (consumed_gas, game_status, balance_updates)) @@ -1005,7 +1007,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)) @@ -1026,7 +1028,7 @@ 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) -> @@ -1035,20 +1037,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 @@ -1122,7 +1127,7 @@ type packed_contents_and_result = 'kind Operation.contents * 'kind contents_result -> packed_contents_and_result -type ('a, 'b) eq = Eq : ('a, 'a) eq +type ('a, 'b) eq = Eq : ('a, 'a) eq [@@coq_force_gadt] let equal_manager_kind : type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option = @@ -1273,7 +1278,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; consensus_key; preendorsement_power} -> @@ -1302,7 +1307,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; consensus_key; endorsement_power} -> (balance_updates, delegate, endorsement_power, consensus_key)); @@ -1326,7 +1331,9 @@ module Encoding = struct | Contents_and_result ((Dal_attestation _ as op), res) -> Some (op, res) | _ -> None); - proj = (function Dal_attestation_result {delegate} -> delegate); + proj = + (function[@coq_match_with_default] + | Dal_attestation_result {delegate} -> delegate); inj = (fun delegate -> Dal_attestation_result {delegate}); } @@ -1345,7 +1352,9 @@ 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); } @@ -1363,7 +1372,8 @@ 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); } @@ -1383,7 +1393,10 @@ 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); } @@ -1404,7 +1417,10 @@ 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); } @@ -1423,7 +1439,9 @@ 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); } @@ -1442,7 +1460,8 @@ 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); } @@ -1458,7 +1477,7 @@ 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); } @@ -1474,7 +1493,7 @@ 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); } @@ -1496,7 +1515,7 @@ module Encoding = struct | Contents_and_result ((Drain_delegate _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Drain_delegate_result {balance_updates; allocated_destination_contract} -> (balance_updates, allocated_destination_contract)); @@ -1522,7 +1541,7 @@ module Encoding = struct (list internal_operation_result_encoding) []); select = - (function + (function[@coq_match_gadt] | Contents_result (Manager_operation_result ({operation_result = Applied res; _} as op)) -> ( @@ -1573,12 +1592,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) -> @@ -1914,8 +1933,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; @@ -1923,10 +1943,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 @@ -1976,8 +1998,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; @@ -1985,15 +2008,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 @@ -2053,27 +2078,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 : @@ -2090,27 +2122,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} @@ -2144,7 +2183,7 @@ let 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 @@ -2175,13 +2214,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 { @@ -2963,7 +3001,7 @@ let rec pack_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) @@ -2997,11 +3035,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_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index dacb11d7976de..dc0baaccc4a7c 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -341,7 +341,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_alpha/lib_protocol/blinded_public_key_hash.ml b/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml index 7b0a3272cc6ee..38a8f65138c2d 100644 --- a/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/bond_id_repr.ml b/src/proto_alpha/lib_protocol/bond_id_repr.ml index 0feb48847f17d..b00e6e59275be 100644 --- a/src/proto_alpha/lib_protocol/bond_id_repr.ml +++ b/src/proto_alpha/lib_protocol/bond_id_repr.ml @@ -69,7 +69,7 @@ let destruct id = 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_alpha/lib_protocol/bootstrap_storage.ml b/src/proto_alpha/lib_protocol/bootstrap_storage.ml index 7c3de02badec1..f1976e7e9bfb4 100644 --- a/src/proto_alpha/lib_protocol/bootstrap_storage.ml +++ b/src/proto_alpha/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 @@ -92,7 +92,12 @@ let init_contract ~typecheck (ctxt, balance_updates) | Some delegate -> Delegate_storage.Contract.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_alpha/lib_protocol/bounded_history_repr.ml b/src/proto_alpha/lib_protocol/bounded_history_repr.ml index d5cf89fea002e..fe315b0ee73f4 100644 --- a/src/proto_alpha/lib_protocol/bounded_history_repr.ml +++ b/src/proto_alpha/lib_protocol/bounded_history_repr.ml @@ -25,6 +25,8 @@ module type NAME = sig val name : string + + val _sig_NAME : unit end module type KEY = sig @@ -35,6 +37,8 @@ module type KEY = sig val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t + + val _sig_KEY : unit end module type VALUE = sig diff --git a/src/proto_alpha/lib_protocol/bounded_history_repr.mli b/src/proto_alpha/lib_protocol/bounded_history_repr.mli index 7195bb86169c7..4918de879b8d7 100644 --- a/src/proto_alpha/lib_protocol/bounded_history_repr.mli +++ b/src/proto_alpha/lib_protocol/bounded_history_repr.mli @@ -36,6 +36,8 @@ This data structure is basically a bounded association table that stores module type NAME = sig val name : string + + val _sig_NAME : unit end (** The required interface for keys stored in the table. *) @@ -47,6 +49,8 @@ module type KEY = sig val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t + + val _sig_KEY : unit end (** The required interface for values stored in the table. *) diff --git a/src/proto_alpha/lib_protocol/cache_repr.ml b/src/proto_alpha/lib_protocol/cache_repr.ml index 2850ff2c9c521..e0832828d10fc 100644 --- a/src/proto_alpha/lib_protocol/cache_repr.ml +++ b/src/proto_alpha/lib_protocol/cache_repr.ml @@ -266,15 +266,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_alpha/lib_protocol/carbonated_map.ml b/src/proto_alpha/lib_protocol/carbonated_map.ml index 95f246ce27dc8..1bd8188e1c804 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/carbonated_map.ml @@ -98,7 +98,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_alpha/lib_protocol/carbonated_map.mli b/src/proto_alpha/lib_protocol/carbonated_map.mli index 745a74514b7b6..94ee3d7752bd2 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.mli +++ b/src/proto_alpha/lib_protocol/carbonated_map.mli @@ -144,18 +144,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_alpha/lib_protocol/contract_repr.ml b/src/proto_alpha/lib_protocol/contract_repr.ml index eff662ff50bc4..e1073e1253d94 100644 --- a/src/proto_alpha/lib_protocol/contract_repr.ml +++ b/src/proto_alpha/lib_protocol/contract_repr.ml @@ -182,7 +182,7 @@ let originated_contracts (Origination_nonce.{origination_index = last; operation_hash = last_hash} as origination_nonce) = assert (Operation_hash.equal first_hash last_hash) ; - let rec contracts acc origination_index = + let[@coq_struct "origination_index"] rec contracts acc origination_index = if Compare.Int32.(origination_index < first) then acc else let origination_nonce = {origination_nonce with origination_index} in diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 0708612f1b4ce..8ee48102d0b57 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -344,7 +344,7 @@ let 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 @@ -356,7 +356,7 @@ let 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 value) in let do_big_map_get_all ?offset ?length ctxt id = @@ -367,7 +367,7 @@ let 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_key_values ?offset ?length ctxt id >>=? fun (ctxt, key_values) -> List.fold_left_s @@ -380,7 +380,7 @@ let 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, value :: rev_values)) (Ok (ctxt, [])) key_values @@ -445,8 +445,12 @@ let 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}, - _ ) -> + >>? fun [@coq_match_gadt_with_result] ( Ex_parameter_ty_and_entrypoints + { + arg_type; + entrypoints; + }, + _ ) -> Gas_monad.run ctxt @@ Script_ir_translator.find_entrypoint ~error_details:(Informative ()) diff --git a/src/proto_alpha/lib_protocol/contract_storage.ml b/src/proto_alpha/lib_protocol/contract_storage.ml index 7364f0a6b7b0e..f82d7e1b7ddab 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/contract_storage.ml @@ -371,44 +371,52 @@ 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 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} -> + Alloc {big_map = id; key_type; value_type} + :: updates))) + | _ -> (* Not a Big_map *) [] + in + diffs :: legacy_diffs) [] diffs |> List.rev |> List.flatten diff --git a/src/proto_alpha/lib_protocol/dal_slot_repr.ml b/src/proto_alpha/lib_protocol/dal_slot_repr.ml index af0696b1d06ba..e6f82839909cf 100644 --- a/src/proto_alpha/lib_protocol/dal_slot_repr.ml +++ b/src/proto_alpha/lib_protocol/dal_slot_repr.ml @@ -276,7 +276,11 @@ module History = struct let title = "A hash that represents the skip list pointers" end - module Pointer_hash = Blake2B.Make (Base58) (Pointer_prefix) + module Pointer_hash = struct + include Blake2B.Make (Base58) (Pointer_prefix) + + let _sig_KEY = () + end module Skip_list_parameters = struct let basis = 2 @@ -299,7 +303,8 @@ module History = struct (fun () -> Add_element_in_slots_skip_list_violates_ordering) module Skip_list = struct - include Skip_list_repr.Make (Skip_list_parameters) + module Skip_list = Skip_list_repr.Make (Skip_list_parameters) + include Skip_list [@@coq_include_without "next" "search"] (** All confirmed DAL slots will be stored in a skip list, where only the last cell is remembered in the L1 context. The skip list is used in @@ -330,10 +335,10 @@ module History = struct 0) Add_element_in_slots_skip_list_violates_ordering in - return @@ next ~prev_cell ~prev_cell_ptr elt + return @@ Skip_list.next ~prev_cell ~prev_cell_ptr elt let search ~deref ~cell ~target_id = - search ~deref ~cell ~compare:(fun slot -> + Skip_list.search ~deref ~cell ~compare:(fun slot -> Header.compare_slot_id slot.Header.id target_id) end @@ -352,7 +357,7 @@ module History = struct type t = history - let history_encoding = + let history_encoding : history Data_encoding.t = Skip_list.encoding Pointer_hash.encoding Header.encoding let equal_history : history -> history -> bool = @@ -364,7 +369,7 @@ module History = struct let genesis : t = Skip_list.genesis Header.zero - let hash_skip_list_cell cell = + let hash_skip_list_cell (cell : history) = let current_slot = Skip_list.content cell in let back_pointers_hashes = Skip_list.back_pointers cell in Data_encoding.Binary.to_bytes_exn Header.encoding current_slot @@ -385,6 +390,8 @@ module History = struct Bounded_history_repr.Make (struct let name = "dal_slots_cache" + + let _sig_NAME = () end) (Pointer_hash) (struct @@ -727,7 +734,7 @@ module History = struct let search_result = Skip_list.search ~deref ~target_id:slot_id ~cell:slots_hist in - match (page_info, search_result.Skip_list.last_cell) with + match (page_info, search_result.last_cell) with | _, Deref_returned_none -> proof_error "Skip_list.search returned 'Deref_returned_none': Slots history \ @@ -750,7 +757,7 @@ module History = struct let* () = check_page_proof dal_params page_proof page_data page_id commitment in - let inc_proof = List.rev search_result.Skip_list.rev_path in + let inc_proof = List.rev search_result.rev_path in let* () = error_when (List.is_empty inc_proof) @@ -772,7 +779,7 @@ module History = struct - if [next_cell_opt] is [None] then, [prev_cell] should be equal to the given history_proof cell. *) let* next_inc_proof = - match search_result.Skip_list.rev_path with + match search_result.rev_path with | [] -> assert false (* Not reachable *) | prev :: rev_next_inc_proof -> let* () = diff --git a/src/proto_alpha/lib_protocol/delegate_cycles.ml b/src/proto_alpha/lib_protocol/delegate_cycles.ml index 943467e4155df..4335ceeecafb7 100644 --- a/src/proto_alpha/lib_protocol/delegate_cycles.ml +++ b/src/proto_alpha/lib_protocol/delegate_cycles.ml @@ -134,8 +134,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 @@ -154,8 +154,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)) @@ -181,8 +181,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)) @@ -229,8 +229,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) @@ -238,9 +238,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)) diff --git a/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml b/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml index 48d3be9240d52..c3e18d825341c 100644 --- a/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml @@ -104,15 +104,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_alpha/lib_protocol/delegate_sampler.ml b/src/proto_alpha/lib_protocol/delegate_sampler.ml index 0040d65f71e7e..e82285dfb5a56 100644 --- a/src/proto_alpha/lib_protocol/delegate_sampler.ml +++ b/src/proto_alpha/lib_protocol/delegate_sampler.ml @@ -91,7 +91,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 diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml index 7479491e0ccfe..8488eb8ba9696 100644 --- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml @@ -67,8 +67,8 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn in let* ctxt = Stake_storage.remove_stake ctxt delegate amount_to_burn in @@ -103,8 +103,8 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn in let* ctxt = Stake_storage.remove_stake ctxt delegate amount_to_burn in diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index 9e7f049b724e5..1a71ea96d504f 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -260,7 +260,7 @@ let drain ctxt ~delegate ~destination = Fees_storage.burn_origination_fees ctxt ~storage_limit:(Z.of_int (Constants_storage.origination_size ctxt)) - ~payer:(`Contract delegate_contract) + ~payer:(Source_container (Contract delegate_contract)) else return (ctxt, Z.zero, []) in let* manager_balance = spendable_balance ctxt delegate in @@ -270,8 +270,8 @@ let drain ctxt ~delegate ~destination = let* ctxt, balance_updates2 = Token.transfer ctxt - (`Contract delegate_contract) - (`Contract destination_contract) + (Source_container (Contract delegate_contract)) + (Sink_container (Contract destination_contract)) transferred in return diff --git a/src/proto_alpha/lib_protocol/dependent_bool.ml b/src/proto_alpha/lib_protocol/dependent_bool.ml index 26d5bd7a9b5e4..e82e863c8822d 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/dependent_bool.mli b/src/proto_alpha/lib_protocol/dependent_bool.mli index 54416d9fd9c3e..a5265a36a14f0 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/fees_storage.ml b/src/proto_alpha/lib_protocol/fees_storage.ml index fd345d65b4e45..c5aad7ca812a9 100644 --- a/src/proto_alpha/lib_protocol/fees_storage.ml +++ b/src/proto_alpha/lib_protocol/fees_storage.ml @@ -90,7 +90,7 @@ let record_paid_storage_space ctxt contract_hash = 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 @@ -109,7 +109,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) ) @@ -123,7 +123,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_alpha/lib_protocol/fitness_repr.ml b/src/proto_alpha/lib_protocol/fitness_repr.ml index 8abc162cf5427..dcaf851549bec 100644 --- a/src/proto_alpha/lib_protocol/fitness_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/fixed_point_repr.ml b/src/proto_alpha/lib_protocol/fixed_point_repr.ml index 079c864431095..531fd045f4537 100644 --- a/src/proto_alpha/lib_protocol/fixed_point_repr.ml +++ b/src/proto_alpha/lib_protocol/fixed_point_repr.ml @@ -28,7 +28,7 @@ type fp_tag (* Tag for fixed point computations *) type integral_tag (* Tag for integral computations *) module type Safe = sig - type 'a t + type 'a t [@@coq_phantom] type fp = fp_tag t @@ -86,7 +86,7 @@ module type Safe = sig end module type Full = sig - type 'a t + type 'a t [@@coq_phantom] include Safe with type 'a t := 'a t diff --git a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml index 62831ed1d33b1..5177384a129e1 100644 --- a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml @@ -105,37 +105,38 @@ 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_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) -> + match[@coq_match_gadt] [@coq_match_with_default] (wit, v) with + | Never_t, _ -> . + | Unit_t, _ -> unit + | Int_t, (v : _ Script_int.num) -> integer v + | Nat_t, (v : _ Script_int.num) -> integer v + | String_t, (v : Script_string.t) -> script_string v + | Bytes_t, (v : bytes) -> bytes v + | Mutez_t, (v : Tez_repr.t) -> mutez v + | Bool_t, (v : bool) -> bool v + | Key_hash_t, (v : Signature.public_key_hash) -> key_hash v + | Timestamp_t, (v : Script_timestamp.t) -> timestamp v + | Address_t, (v : Script_typed_ir.address) -> address v + | Tx_rollup_l2_address_t, (v : Script_typed_ir.tx_rollup_l2_address) -> + tx_rollup_l2_address v + | Pair_t (leaf, node, _, YesYes), (v : _ * _) -> let lv, rv = v 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), (v : _ Script_typed_ir.union) -> let size = match v with | L v -> size_of_comparable_value left v | R v -> size_of_comparable_value right v in size + 1 - | Option_t (ty, _, Yes) -> ( + | Option_t (ty, _, Yes), (v : _ option) -> ( 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 + | Signature_t, (v : Script_typed_ir.signature) -> signature v + | Key_t, (v : Signature.public_key) -> public_key v + | Chain_id_t, (v : Script_typed_ir.Script_chain_id.t) -> chain_id v diff --git a/src/proto_alpha/lib_protocol/gas_input_size.ml b/src/proto_alpha/lib_protocol/gas_input_size.ml index d4105ef06ca12..c9bebe6f65d06 100644 --- a/src/proto_alpha/lib_protocol/gas_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_input_size.ml @@ -51,7 +51,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_alpha/lib_protocol/gas_limit_repr.mli b/src/proto_alpha/lib_protocol/gas_limit_repr.mli index 891fd46f1c0be..9df5f75ee59ba 100644 --- a/src/proto_alpha/lib_protocol/gas_limit_repr.mli +++ b/src/proto_alpha/lib_protocol/gas_limit_repr.mli @@ -42,6 +42,7 @@ module Arith : Fixed_point_repr.Full with type 'a t = private Saturation_repr.may_saturate Saturation_repr.t +[@@coq_plain_module] type t = Unaccounted | Limited of {remaining : Arith.fp} diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 3597f4bfa47f6..bdeddc00a3cf8 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/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 @@ -80,16 +80,16 @@ let run ctxt m = | None -> error Gas.Operation_quota_exceeded) let record_trace_eval : - type error_trace error_context. + type a error_trace error_context. error_details:(error_context, error_trace) Script_tc_errors.error_details -> (error_context -> error) -> - ('a, error_trace) t -> - ('a, error_trace) t = - fun ~error_details -> - match error_details with - | Fast -> fun _f m -> m - | Informative err_ctxt -> - 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 err_ctxt, (m : (_, error trace) t) -> + fun gas -> m gas >>?? fun (x, gas) -> of_result (record_trace_eval (fun () -> f err_ctxt) x) gas diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml index e34c04c0bb081..2b4536c74fc12 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml @@ -36,26 +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 + traverse_node initial_accumulator node f initial_k module Gas_costs = Global_constants_costs module Expr_hash_map = Map.Make (Script_expr_hash) @@ -224,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_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index 0dce5fd663ed1..670450c0d98d9 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/indexable.mli b/src/proto_alpha/lib_protocol/indexable.mli index cc921e802f1f6..e71d8926bc4a5 100644 --- a/src/proto_alpha/lib_protocol/indexable.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index f54a68ba42c83..75a3055114840 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -44,8 +44,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 @@ -124,8 +124,8 @@ let prepare_first_block _chain_id ctxt ~typecheck ~level ~timestamp ~predecessor 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_alpha/lib_protocol/lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/lazy_storage_diff.ml index 791b3f828448f..2edaa2e934af2 100644 --- a/src/proto_alpha/lib_protocol/lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/lazy_storage_diff.ml @@ -183,7 +183,7 @@ 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) @@ -353,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 @@ -365,9 +365,11 @@ 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 @@ -411,23 +413,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 + 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 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)) diff --git a/src/proto_alpha/lib_protocol/lazy_storage_kind.ml b/src/proto_alpha/lib_protocol/lazy_storage_kind.ml index 03655e7e956e0..7e0ef5cba642a 100644 --- a/src/proto_alpha/lib_protocol/lazy_storage_kind.ml +++ b/src/proto_alpha/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)) @@ -250,23 +250,23 @@ module Temp_ids = struct (temp_ids.sapling_state :> Sapling_state.Id.t) ) 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 @@ -282,17 +282,17 @@ 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 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} @@ -303,16 +303,19 @@ module IdSet = struct in {big_map; sapling_state} - 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 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 end diff --git a/src/proto_alpha/lib_protocol/level_repr.ml b/src/proto_alpha/lib_protocol/level_repr.ml index f4cb006b83177..805295c92326b 100644 --- a/src/proto_alpha/lib_protocol/level_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/level_storage.ml b/src/proto_alpha/lib_protocol/level_storage.ml index 331839bf787bb..057588f457f39 100644 --- a/src/proto_alpha/lib_protocol/level_storage.ml +++ b/src/proto_alpha/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 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 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_alpha/lib_protocol/liquidity_baking_migration.ml b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml index 59a8eb2c65490..4e8445002de81 100644 --- a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index 96be7e48fbf1f..db0c084f7c1ca 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -394,7 +394,42 @@ let value_of_key ~chain_id:_ ~predecessor_context:ctxt ~predecessor_timestamp >>=? fun (ctxt, _, _) -> return (Apply.value_of_key ctxt) module Mempool = struct - include Mempool_validation + type t = Mempool_validation.t + + type validation_info = Mempool_validation.validation_info + + type keep_or_replace = Mempool_validation.keep_or_replace = Keep | Replace + + type conflict_handler = Mempool_validation.conflict_handler + + type operation_conflict = Validate_errors.operation_conflict = + | Operation_conflict of { + existing : Operation_list_hash.elt; + new_operation : Operation_list_hash.elt; + } + + type add_result = Mempool_validation.add_result = + | Added + | Replaced of {removed : Operation_list_hash.elt} + | Unchanged + + type add_error = Mempool_validation.add_error = + | Validation_error of error trace + | Add_conflict of operation_conflict + + type merge_error = Mempool_validation.merge_error = + | Incompatible_mempool + | Merge_conflict of operation_conflict + + let encoding = Mempool_validation.encoding + + let add_operation = Mempool_validation.add_operation + + let remove_operation = Mempool_validation.remove_operation + + let merge = Mempool_validation.merge + + let operations = Mempool_validation.operations let init ctxt chain_id ~head_hash ~(head : Block_header.shell_header) = let open Lwt_result_syntax in @@ -415,7 +450,7 @@ module Mempool = struct let predecessor_round = Fitness.round fitness in let grandparent_round = Fitness.predecessor_round fitness in return - (init + (Mempool_validation.init ctxt chain_id ~predecessor_level:head_level diff --git a/src/proto_alpha/lib_protocol/mempool_validation.ml b/src/proto_alpha/lib_protocol/mempool_validation.ml index 8493f18a7e13f..a20e3cac882e2 100644 --- a/src/proto_alpha/lib_protocol/mempool_validation.ml +++ b/src/proto_alpha/lib_protocol/mempool_validation.ml @@ -36,11 +36,7 @@ type validation_info = Validate.info type add_result = Added | Replaced of {removed : Operation_hash.t} | Unchanged -type operation_conflict = Validate_errors.operation_conflict = - | Operation_conflict of { - existing : Operation_hash.t; - new_operation : Operation_hash.t; - } +type operation_conflict = Validate_errors.operation_conflict type add_error = | Validation_error of error trace @@ -78,10 +74,12 @@ let init ctxt chain_id ~predecessor_level ~predecessor_round ~predecessor_hash {predecessor_hash; operation_state; operations = Operation_hash.Map.empty} ) +type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * packed_operation -> new_operation:Operation_hash.t * packed_operation -> - [`Keep | `Replace] + keep_or_replace let remove_operation mempool oph = match Operation_hash.Map.find_opt oph mempool.operations with @@ -128,8 +126,8 @@ let add_operation ?(check_signature = true) | Some op -> (existing, op) in match handler ~existing_operation ~new_operation with - | `Keep -> Lwt.return_ok (mempool, Unchanged) - | `Replace -> + | Keep -> Lwt.return_ok (mempool, Unchanged) + | Replace -> let mempool = remove_operation mempool existing in let operation_state = add_valid_operation @@ -145,6 +143,10 @@ let add_operation ?(check_signature = true) Replaced {removed = existing} )) | None -> Lwt.return_error (Add_conflict x))) +module Add_replace_or_nothing = struct + type t = Add_new | Replace of Operation_list_hash.elt | Do_nothing +end + let merge ?conflict_handler existing_mempool new_mempool = if Block_hash.( @@ -168,9 +170,9 @@ let merge ?conflict_handler existing_mempool new_mempool = let unopt_assert = function None -> assert false | Some o -> o in let handle_conflict new_operation_content conflict = match (conflict, conflict_handler) with - | Ok (), _ -> Ok `Add_new + | Ok (), _ -> Ok Add_replace_or_nothing.Add_new | Error conflict, None -> Error (Merge_conflict conflict) - | ( Error (Operation_conflict {existing; new_operation}), + | ( Error (Validate_errors.Operation_conflict {existing; new_operation}), Some (f : conflict_handler) ) -> ( (* New operations can only conflict with operations already present in the existing mempool. *) @@ -183,8 +185,8 @@ let merge ?conflict_handler existing_mempool new_mempool = ~existing_operation:(existing, existing_operation_content) ~new_operation:(new_operation, new_operation_content) with - | `Keep -> Ok `Do_nothing - | `Replace -> Ok (`Replace existing)) + | Keep -> Ok Add_replace_or_nothing.Do_nothing + | Replace -> Ok (Add_replace_or_nothing.Replace existing)) in Operation_hash.Map.fold_e (fun roph packed_right_op mempool_acc -> @@ -197,8 +199,8 @@ let merge ?conflict_handler existing_mempool new_mempool = |> handle_conflict packed_right_op in match conflict with - | `Do_nothing -> return mempool_acc - | `Add_new -> + | Add_replace_or_nothing.Do_nothing -> return mempool_acc + | Add_replace_or_nothing.Add_new -> let operation_state = add_valid_operation mempool_acc.operation_state roph right_op in @@ -206,7 +208,7 @@ let merge ?conflict_handler existing_mempool new_mempool = Operation_hash.Map.add roph packed_right_op mempool_acc.operations in return {mempool_acc with operation_state; operations} - | `Replace loph -> + | Add_replace_or_nothing.Replace loph -> let mempool_acc = remove_operation mempool_acc loph in let operation_state = add_valid_operation mempool_acc.operation_state roph right_op diff --git a/src/proto_alpha/lib_protocol/mempool_validation.mli b/src/proto_alpha/lib_protocol/mempool_validation.mli index 6ed036b88545c..00cd1015def4d 100644 --- a/src/proto_alpha/lib_protocol/mempool_validation.mli +++ b/src/proto_alpha/lib_protocol/mempool_validation.mli @@ -61,6 +61,8 @@ type t mempool. *) type validation_info +type keep_or_replace = Keep | Replace + (** Type of the function that may be provided in order to resolve a potential conflict when adding an operation to an existing mempool or when merging two mempools. This handler may be defined as a @@ -74,7 +76,7 @@ type validation_info type conflict_handler = existing_operation:Operation_hash.t * packed_operation -> new_operation:Operation_hash.t * packed_operation -> - [`Keep | `Replace] + keep_or_replace (** Return type when adding an operation to the mempool *) type add_result = @@ -91,11 +93,7 @@ type add_result = [conflict_handler], therefore the new operation is discarded and the mempool remains unchanged. *) -type operation_conflict = Validate_errors.operation_conflict = - | Operation_conflict of { - existing : Operation_hash.t; - new_operation : Operation_hash.t; - } +type operation_conflict = Validate_errors.operation_conflict (** Error type returned when adding an operation to the mempool fails. *) type add_error = diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index bc41e7f1651a8..b1b6bcf8c4ac7 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/merkle_list.mli b/src/proto_alpha/lib_protocol/merkle_list.mli index 2352d451b7738..8a40dbe749eee 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 23b1d88841883..78f1bc3fed4fa 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -482,31 +482,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 @@ -516,7 +522,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 @@ -524,7 +532,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 @@ -534,12 +542,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 + 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_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index b8ae12fc1997c..11faca38b6d57 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -236,7 +236,9 @@ let namespace = function let valid_case name = let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in - let rec for_all a b f = Compare.Int.(a > b) || (f a && for_all (a + 1) b f) in + let[@coq_struct "a_value"] rec for_all a b f = + Compare.Int.(a > b) || (f a && for_all (a + 1) b f) + in let len = String.length name in Compare.Int.(len <> 0) && Compare.Char.(name.[0] <> '_') @@ -563,8 +565,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)) @@ -576,8 +580,10 @@ let prims_of_strings expr = convert (root expr) >|? fun expr -> strip_locations expr 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 diff --git a/src/proto_alpha/lib_protocol/misc.ml b/src/proto_alpha/lib_protocol/misc.ml index 817c53730049b..307b43dc4b398 100644 --- a/src/proto_alpha/lib_protocol/misc.ml +++ b/src/proto_alpha/lib_protocol/misc.ml @@ -31,38 +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 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 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 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] + 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_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index c524f5951e0ed..9ee5d17256326 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/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 @@ -164,15 +165,16 @@ module Kind = struct | Zk_rollup_update_manager_kind : zk_rollup_update 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; @@ -213,10 +215,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_attestation of Chain_id.t +module Consensus_watermark = struct + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_attestation of Chain_id.t +end + +open Consensus_watermark let bytes_of_consensus_watermark = function | Preendorsement chain_id -> @@ -647,6 +653,7 @@ module Encoding = struct inj : 'a -> 'kind manager_operation; } -> 'kind case + [@@coq_force_gadt] let reveal_case = MCase @@ -655,7 +662,7 @@ module Encoding = struct 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); } @@ -676,7 +683,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 @@ -709,7 +716,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 = @@ -725,7 +732,7 @@ 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); } @@ -738,7 +745,9 @@ 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}); } @@ -751,7 +760,8 @@ 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); } @@ -768,7 +778,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 = @@ -787,7 +797,9 @@ module Encoding = struct select = (function | Manager (Update_consensus_key _ as op) -> Some op | _ -> None); - proj = (function Update_consensus_key consensus_pk -> consensus_pk); + proj = + (function[@coq_match_with_default] + | Update_consensus_key consensus_pk -> consensus_pk); inj = (fun consensus_pk -> Update_consensus_key consensus_pk); } @@ -800,7 +812,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); } @@ -818,7 +831,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 = @@ -839,7 +852,7 @@ 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) -> @@ -855,7 +868,9 @@ 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}); } @@ -870,7 +885,8 @@ 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}); } @@ -885,7 +901,8 @@ 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}); } @@ -918,7 +935,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; @@ -990,7 +1007,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; @@ -1041,7 +1058,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)); @@ -1070,7 +1087,7 @@ module Encoding = struct (function | Manager (Zk_rollup_origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Zk_rollup_origination {public_parameters; circuits_info; init_state; nb_ops} -> (public_parameters, circuits_info, init_state, nb_ops)); @@ -1097,7 +1114,8 @@ module Encoding = struct (function | Manager (Zk_rollup_publish _ as op) -> Some op | _ -> None); proj = - (function Zk_rollup_publish {zk_rollup; ops} -> (zk_rollup, ops)); + (function[@coq_match_with_default] + | Zk_rollup_publish {zk_rollup; ops} -> (zk_rollup, ops)); inj = (fun (zk_rollup, ops) -> Zk_rollup_publish {zk_rollup; ops}); } @@ -1135,7 +1153,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; origination_proof; parameters_ty} -> (kind, boot_sector, origination_proof, parameters_ty)); @@ -1155,7 +1173,8 @@ module Encoding = struct (function | Manager (Dal_publish_slot_header _ as op) -> Some op | _ -> None); proj = - (function Dal_publish_slot_header {slot_header} -> slot_header); + (function[@coq_match_with_default] + | Dal_publish_slot_header {slot_header} -> slot_header); inj = (fun slot_header -> Dal_publish_slot_header {slot_header}); } @@ -1168,7 +1187,9 @@ module Encoding = struct select = (function | Manager (Sc_rollup_add_messages _ as op) -> Some op | _ -> None); - proj = (function Sc_rollup_add_messages {messages} -> messages); + proj = + (function[@coq_match_with_default] + | Sc_rollup_add_messages {messages} -> messages); inj = (fun messages -> Sc_rollup_add_messages {messages}); } @@ -1185,7 +1206,7 @@ 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}); @@ -1204,7 +1225,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}); @@ -1224,7 +1245,7 @@ module Encoding = struct (function | Manager (Sc_rollup_refute _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_refute {rollup; opponent; refutation} -> (rollup, opponent, refutation)); inj = @@ -1245,7 +1266,7 @@ module Encoding = struct (function | Manager (Sc_rollup_timeout _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_timeout {rollup; stakers} -> (rollup, stakers)); inj = (fun (rollup, stakers) -> Sc_rollup_timeout {rollup; stakers}); } @@ -1267,7 +1288,7 @@ module Encoding = struct | Manager (Sc_rollup_execute_outbox_message _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_execute_outbox_message {rollup; cemented_commitment; output_proof} -> (rollup, cemented_commitment, output_proof)); @@ -1286,7 +1307,9 @@ module Encoding = struct select = (function | Manager (Sc_rollup_recover_bond _ as op) -> Some op | _ -> None); - proj = (function Sc_rollup_recover_bond {sc_rollup} -> sc_rollup); + proj = + (function[@coq_match_with_default] + | Sc_rollup_recover_bond {sc_rollup} -> sc_rollup); inj = (fun sc_rollup -> Sc_rollup_recover_bond {sc_rollup}); } end @@ -1310,15 +1333,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 @@ -1340,23 +1369,21 @@ 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 = - (fun (Endorsement consensus_content) -> + (fun [@coq_match_with_default] (Endorsement consensus_content) -> ( consensus_content.slot, consensus_content.level, consensus_content.round, @@ -1367,10 +1394,15 @@ module Encoding = struct } let endorsement_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.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 @@ -1403,8 +1435,9 @@ module Encoding = struct select = (function Contents (Dal_attestation _ as op) -> Some op | _ -> None); proj = - (fun (Dal_attestation - Dal_attestation_repr.{attestor; attestation; level}) -> + (fun [@coq_match_with_default] (Dal_attestation + Dal_attestation_repr. + {attestor; attestation; level}) -> (attestor, attestation, level)); inj = (fun (attestor, attestation, level) -> @@ -1423,7 +1456,9 @@ 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}); } @@ -1435,7 +1470,9 @@ 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}); } @@ -1453,7 +1490,10 @@ 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}); } @@ -1470,7 +1510,10 @@ 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}); } @@ -1486,7 +1529,9 @@ 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}); } @@ -1503,7 +1548,8 @@ 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}); @@ -1526,7 +1572,7 @@ 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) -> @@ -1546,7 +1592,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 = @@ -1567,7 +1613,7 @@ module Encoding = struct select = (function Contents (Drain_delegate _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Drain_delegate {consensus_key; delegate; destination} -> (consensus_key, delegate, destination)); inj = @@ -1583,7 +1629,8 @@ module Encoding = struct encoding = obj1 (req "arbitrary" (string' Hex)); select = (function Contents (Failing_noop _ as op) -> Some op | _ -> None); - proj = (function Failing_noop message -> message); + proj = + (function[@coq_match_with_default] Failing_noop message -> message); inj = (function message -> Failing_noop message); } @@ -1595,7 +1642,8 @@ module Encoding = struct (req "gas_limit" (check_size 10 Gas_limit_repr.Arith.n_integral_encoding)) (req "storage_limit" (check_size 10 n)) - let extract : type kind. kind Kind.manager contents -> _ = function + let extract : type kind. kind Kind.manager contents -> _ = + function[@coq_match_with_default] | Manager_operation {source; fee; counter; gas_limit; storage_limit; operation = _} -> (source, fee, counter, gas_limit, storage_limit) @@ -1604,8 +1652,9 @@ module Encoding = struct Manager_operation {source; fee; counter; gas_limit; storage_limit; operation} - let 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; @@ -1619,7 +1668,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)); @@ -1753,13 +1802,16 @@ module Encoding = struct Manager_operations.zk_rollup_update_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 @@ -1874,7 +1926,7 @@ let manager_pass = 3 when defines and None when [op] is [Failing_noop]. *) let acceptable_pass (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 _) -> None | Single (Preendorsement _) -> Some consensus_pass | Single (Endorsement _) -> Some consensus_pass @@ -1957,7 +2009,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)) @@ -2004,7 +2056,7 @@ let hash_packed (o : packed_operation) = in Operation.hash {shell = o.shell; proto} -type ('a, 'b) eq = Eq : ('a, 'a) eq +type ('a, 'b) eq = Eq : ('a, 'a) eq [@@coq_force_gadt] let equal_manager_operation_kind : type a b. a manager_operation -> b manager_operation -> (a, b) eq option = @@ -2147,15 +2199,17 @@ type manager_pass_type type noop_pass_type -type _ pass = - | Consensus : consensus_pass_type pass - | Voting : voting_pass_type pass - | Anonymous : anonymous_pass_type pass - | Manager : manager_pass_type pass - | Noop : noop_pass_type pass +module Pass = struct + type _ t = + | Consensus : consensus_pass_type t + | Voting : voting_pass_type t + | Anonymous : anonymous_pass_type t + | Manager : manager_pass_type t + | Noop : noop_pass_type t +end (** Pass comparison. *) -let compare_inner_pass : type a b. a pass -> b pass -> int = +let compare_inner_pass : type a b. a Pass.t -> b Pass.t -> int = fun pass1 pass2 -> match (pass1, pass2) with | Consensus, (Voting | Anonymous | Manager | Noop) -> 1 @@ -2305,7 +2359,7 @@ type _ weight = | Weight_noop : noop_pass_type weight (** The weight of an operation is the pair of its pass and weight. *) -type operation_weight = W : 'pass pass * 'pass weight -> operation_weight +type operation_weight = W : 'pass Pass.t * 'pass weight -> operation_weight (** The {!weight} of a batch of {!Manager_operation} depends on the sum of all [fee] and the sum of all [gas_limit]. @@ -2323,9 +2377,9 @@ let cumulate_fee_and_gas_of_manager : | Ok v -> v | Error _ -> (* This cannot happen *) acc in - let rec loop : + let[@coq_struct "function_parameter"] rec loop : type kind. 'a -> 'b -> kind Kind.manager contents_list -> 'a * 'b = - fun fees_acc gas_limit_acc -> function + fun fees_acc gas_limit_acc -> function[@coq_match_with_default] | Single (Manager_operation {fee; gas_limit; _}) -> let total_fees = add_without_error fees_acc fee in let total_gas_limit = @@ -2353,7 +2407,7 @@ let weight_manager : fun op -> let fee, glimit = cumulate_fee_and_gas_of_manager op in let source = - match op with + match[@coq_match_with_default] op with | Cons (Manager_operation {source; _}, _) -> source | Single (Manager_operation {source; _}) -> source in @@ -2370,7 +2424,7 @@ let weight_manager : let weight_of : packed_operation -> operation_weight = fun op -> 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 _) -> W (Noop, Weight_noop) | Single (Preendorsement consensus_content) -> W @@ -2399,14 +2453,14 @@ let weight_of : packed_operation -> operation_weight = | Single (Vdf_revelation {solution}) -> W (Anonymous, Weight_vdf_revelation solution) | Single (Double_endorsement_evidence {op1; _}) -> ( - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Endorsement consensus_content) -> W ( Anonymous, Weight_double_endorsement (round_infos_from_consensus_content consensus_content) )) | Single (Double_preendorsement_evidence {op1; _}) -> ( - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement consensus_content) -> W ( Anonymous, @@ -2542,7 +2596,7 @@ let compare_dal_attestation (attestor1, endorsements1, level1) consensus operations. Two valid {!Dal_attestation} are compared by {!compare_dal_attestation}. *) let compare_consensus_weight w1 w2 = - match (w1, w2) with + match[@coq_match_with_default] (w1, w2) with | Weight_endorsement infos1, Weight_endorsement infos2 -> compare_endorsement_infos ~prioritized_position:Nopos infos1 infos2 | Weight_preendorsement infos1, Weight_preendorsement infos2 -> @@ -2574,7 +2628,7 @@ let compare_vote_weight w1 w2 = ~cmp_fst:Compare.Int32.compare ~cmp_snd:Signature.Public_key_hash.compare in - match (w1, w2) with + match[@coq_match_with_default] (w1, w2) with | Weight_proposals (i1, source1), Weight_proposals (i2, source2) -> cmp i1 source1 i2 source2 | Weight_ballot (i1, source1), Weight_ballot (i2, source2) -> @@ -2605,7 +2659,7 @@ let compare_vote_weight w1 w2 = {!Vdf_revelation} > {!Seed_nonce_revelation} > {!Activate_account}. *) let compare_anonymous_weight w1 w2 = - match (w1, w2) with + match[@coq_match_with_default] (w1, w2) with | Weight_double_preendorsement infos1, Weight_double_preendorsement infos2 -> compare_round_infos infos1 infos2 | Weight_double_preendorsement infos1, Weight_double_endorsement infos2 -> @@ -2671,7 +2725,7 @@ let compare_anonymous_weight w1 w2 = of their pair of their [fee]/[gas] ratio -- as computed by {!weight_manager} -- and their [source]. *) let compare_manager_weight weight1 weight2 = - match (weight1, weight2) with + match[@coq_match_with_default] (weight1, weight2) with | Weight_manager (manweight1, source1), Weight_manager (manweight2, source2) -> compare_pair_in_lexico_order diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index d2b6720e8a9a6..f90342b9db044 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -196,12 +196,13 @@ module Kind : sig | Zk_rollup_update_manager_kind : zk_rollup_update 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; @@ -218,10 +219,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_attestation of Chain_id.t +module Consensus_watermark : sig + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_attestation of Chain_id.t +end + +open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 3ca2c5123afa0..96c8b4803286f 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1759,3 +1759,79 @@ end = struct let length local i = Tree.length (tree local) i 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 + + type nonrec local_context = local_context + + let with_local_context = with_local_context + + module Local_context = Local_context + + let length = length +end diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index f7e6114a41c18..e372fbae00e28 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -474,3 +474,5 @@ module Dal : sig for the current level. *) val init_committee : t -> committee -> t end + +module M : T with type t = root diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index fa4789f7c8bd1..36eced8c398b3 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/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,38 +247,7 @@ 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. +(** 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 @@ -311,9 +273,9 @@ module type PROOF = sig 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} +type ('a, 'index) inode = {length : int; proofs : ('index * 'a) list} - (** The type for inode extenders. +(** 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 @@ -324,9 +286,13 @@ module type PROOF = sig 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} +type ('a, 'index) inode_extender = { + length : int; + segment : 'index list; + proof : 'a; +} - (** The type for compressed and partial Merkle tree proofs. +(** 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 @@ -350,15 +316,16 @@ module type PROOF = sig [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 +type ('step, 'value, 'index, 'hash) tree = + | Value of 'value + | Blinded_value of 'hash + | Node of ('step * ('step, 'value, 'index, 'hash) tree) list + | Blinded_node of 'hash + | Inode of (('step, 'value, 'index, 'hash) inode_tree, 'index) inode + | Extender of + (('step, 'value, 'index, 'hash) inode_tree, 'index) inode_extender - (** The type for inode trees. It is a subset of [tree], limited to nodes. +(** 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. @@ -367,11 +334,51 @@ module type PROOF = sig [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 +and ('step, 'value, 'index, 'hash) inode_tree = + | Blinded_inode of 'hash + | Inode_values of ('step * ('step, 'value, 'index, 'hash) tree) list + | Inode_tree of (('step, 'value, 'index, 'hash) inode_tree, 'index) inode + | Inode_extender of + (('step, 'value, 'index, 'hash) inode_tree, 'index) inode_extender + +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 + + type nonrec 'a inode = ('a, index) inode + + type nonrec 'a inode_extender = ('a, index) inode_extender + + type nonrec tree = (step, value, index, hash) tree + + type nonrec inode_tree = (step, value, index, hash) inode_tree (** The type for kinded hashes. *) type kinded_hash = [`Value of hash | `Node of hash] @@ -464,8 +471,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 +522,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 +531,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_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml index 4f8c5c7b20eec..44f881b5f079e 100644 --- a/src/proto_alpha/lib_protocol/round_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/sampler.ml b/src/proto_alpha/lib_protocol/sampler.ml index 043e05945f86e..1aab07130e6e3 100644 --- a/src/proto_alpha/lib_protocol/sampler.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/sapling_repr.ml b/src/proto_alpha/lib_protocol/sapling_repr.ml index 0e54e90a57272..7e1bbc0a261e9 100644 --- a/src/proto_alpha/lib_protocol/sapling_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml index e043a080a46f5..88a33e6239695 100644 --- a/src/proto_alpha/lib_protocol/sapling_storage.ml +++ b/src/proto_alpha/lib_protocol/sapling_storage.ml @@ -149,7 +149,7 @@ module Commitments : COMMITMENTS = struct pos = size tree /\ Post: incremental tree /\ to_list (insert tree height pos cms) = to_list t @ cms *) - let rec insert ctx id node height pos cms = + let[@coq_struct "height"] rec insert ctx id node height pos cms = assert_node node height ; assert_height height ; assert_pos pos height ; @@ -178,7 +178,8 @@ module Commitments : COMMITMENTS = struct Storage.Sapling.Commitments.add (ctx, id) node h >|=? fun (ctx, size, _existing) -> (ctx, size + size_children, h) - let rec fold_from_height ctx id node ~pos ~f ~acc height = + let[@coq_struct "height"] rec fold_from_height ctx id node ~pos ~f ~acc height + = assert_node node height ; assert_height height ; assert_pos pos height ; @@ -239,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) @@ -278,7 +279,7 @@ module Nullifiers = struct (ctx, size) let get_from ctx id offset = - let rec aux acc pos = + let[@coq_struct "pos"] rec aux acc pos = Storage.Sapling.Nullifiers_ordered.find (ctx, id) pos >>=? function | None -> return @@ List.rev acc | Some c -> aux (c :: acc) (Int64.succ pos) @@ -305,7 +306,7 @@ module Roots = struct Storage.Sapling.Roots.get (ctx, id) pos let init ctx id = - let rec aux ctx pos = + let[@coq_struct "pos"] rec aux ctx pos = if Compare.Int32.(pos < 0l) then return ctx else Storage.Sapling.Roots.init (ctx, id) pos Commitments.default_root @@ -318,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_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 42ca2e4543646..e2e6a414edc66 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -122,8 +122,6 @@ module type S = sig val pp_boot_sector : Format.formatter -> string -> unit - val pp : state -> (Format.formatter -> unit -> unit) Lwt.t - val get_tick : state -> Sc_rollup_tick_repr.t Lwt.t type status = @@ -174,11 +172,11 @@ module Make (Context : P) : type proof = Context.proof - let proof_encoding = Context.proof_encoding + let proof_encoding : proof Data_encoding.t = Context.proof_encoding - let proof_start_state proof = Context.proof_before proof + let proof_start_state (proof : proof) = Context.proof_before proof - let proof_stop_state proof = Context.proof_after proof + let proof_stop_state (proof : proof) = Context.proof_after proof let name = "arith" @@ -351,7 +349,7 @@ module Make (Context : P) : open Monad - module Make_var (P : sig + module type P_MakeVar = sig type t val name : string @@ -361,8 +359,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 Make_var (P : P_MakeVar) : S_MakeVar with type t := P.t = struct let key = [P.name] let create = set_value key P.encoding P.initial @@ -384,7 +395,7 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end - module Make_dict (P : sig + module type P_MakeDict = sig type t val name : string @@ -392,8 +403,23 @@ 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 entries : (string * t) list Monad.t + + val mapped_to : string -> t -> state -> bool Lwt.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module Make_dict (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 @@ -405,8 +431,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 = @@ -418,14 +444,31 @@ module Make (Context : P) : return @@ fun fmt () -> Format.pp_print_list pp_elem fmt l end - module Make_deque (P : sig + module type P_deque = sig type t val name : string val encoding : t Data_encoding.t - end) = - struct + 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 Make_deque (P : P_deque) : MakeDeque_sig with type t := P.t = struct (* A stateful deque. @@ -494,7 +537,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 @@ -508,9 +551,15 @@ module Make (Context : P) : end module Current_tick = Make_var (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 = Make_dict (struct @@ -1405,7 +1454,8 @@ module Make (Context : P) : | None -> tzfail Arith_proof_verification_failed | Some (_state, request) -> return request - let produce_proof context input_given state = + let produce_proof context input_given state : + (proof, error trace) result Lwt.t = let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) @@ -1414,7 +1464,7 @@ module Make (Context : P) : | Some (tree_proof, _requested) -> return tree_proof | None -> tzfail Arith_proof_production_failed - let verify_origination_proof proof boot_sector = + let verify_origination_proof (proof : proof) boot_sector = let open Lwt_syntax in let before = Context.proof_before proof in if State_hash.(before <> reference_initial_state_hash) then return false @@ -1426,7 +1476,8 @@ module Make (Context : P) : in match result with None -> return false | Some (_, ()) -> return true - let produce_origination_proof context boot_sector = + let produce_origination_proof context boot_sector : + (proof, error trace) result Lwt.t = let open Lwt_result_syntax in let*! state = initial_state ~empty:(Tree.empty context) in let*! result = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.mli b/src/proto_alpha/lib_protocol/sc_rollup_arith.mli index 0983dd3a9587c..15140be342038 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.mli @@ -84,9 +84,6 @@ module type S = sig a boot sector. *) val pp_boot_sector : Format.formatter -> string -> unit - (** [pp state] returns a pretty-printer valid for [state]. *) - val pp : state -> (Format.formatter -> unit -> unit) Lwt.t - (** [get_tick state] returns the current tick of [state]. *) val get_tick : state -> Sc_rollup_tick_repr.t Lwt.t diff --git a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml index 47d9df611560b..955131a269b0a 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml @@ -24,6 +24,11 @@ (* *) (*****************************************************************************) +type sc_rollup_staker_in_game_error = + | Refuter of Signature.public_key_hash + | Defender of Signature.public_key_hash + | Both of Signature.public_key_hash * Signature.public_key_hash + type error += | (* `Temporary *) Sc_rollup_disputed | (* `Temporary *) Sc_rollup_does_not_exist of Sc_rollup_repr.t @@ -48,10 +53,7 @@ type error += | (* `Temporary *) Sc_rollup_wrong_turn | (* `Temporary *) Sc_rollup_no_game | (* `Temporary *) - Sc_rollup_staker_in_game of - [ `Refuter of Signature.public_key_hash - | `Defender of Signature.public_key_hash - | `Both of Signature.public_key_hash * Signature.public_key_hash ] + Sc_rollup_staker_in_game of sc_rollup_staker_in_game_error | (* `Temporary *) Sc_rollup_timeout_level_not_reached of int32 * Signature.public_key_hash @@ -81,19 +83,19 @@ let () = ~description:"Attempted to start a game where one staker is already busy" ~pp:(fun ppf staker -> let busy ppf = function - | `Refuter sc -> + | Refuter sc -> Format.fprintf ppf "the refuter (%a) is" Signature.Public_key_hash.pp sc - | `Defender sc -> + | Defender sc -> Format.fprintf ppf "the defender (%a) is" Signature.Public_key_hash.pp sc - | `Both (refuter, defender) -> + | Both (refuter, defender) -> Format.fprintf ppf "both the refuter (%a) and the defender (%a) are" @@ -114,14 +116,14 @@ let () = (Tag 0) ~title:"Refuter" (obj1 (req "refuter" Signature.Public_key_hash.encoding)) - (function `Refuter sc -> Some sc | _ -> None) - (fun sc -> `Refuter sc); + (function Refuter sc -> Some sc | _ -> None) + (fun sc -> Refuter sc); case (Tag 1) ~title:"Defender" (obj1 (req "defender" Signature.Public_key_hash.encoding)) - (function `Defender sc -> Some sc | _ -> None) - (fun sc -> `Defender sc); + (function Defender sc -> Some sc | _ -> None) + (fun sc -> Defender sc); case (Tag 2) ~title:"Both" @@ -129,9 +131,8 @@ let () = (req "refuter" Signature.Public_key_hash.encoding) (req "defender" Signature.Public_key_hash.encoding)) (function - | `Both (refuter, defender) -> Some (refuter, defender) - | _ -> None) - (fun (refuter, defender) -> `Both (refuter, defender)); + | Both (refuter, defender) -> Some (refuter, defender) | _ -> None) + (fun (refuter, defender) -> Both (refuter, defender)); ]) (function Sc_rollup_staker_in_game x -> Some x | _ -> None) (fun x -> Sc_rollup_staker_in_game x) ; diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index 54e5356ec5cf4..1896ae5d2afb8 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -664,7 +664,7 @@ let status_encoding = let find_choice dissection tick = let open Result_syntax in - let rec traverse states = + let[@coq_struct "states"] rec traverse states = match states with | ({state_hash = _; tick = state_tick} as curr) :: next :: others -> if Sc_rollup_tick_repr.(tick = state_tick) then return (curr, next) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml index 44f2efee02dfd..c2632e51a926d 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml @@ -123,8 +123,14 @@ module History = struct Bounded_history_repr.Make (struct let name = "level_inbox_history" + + let _sig_NAME = () + end) + (struct + include Hash + + let _sig_KEY = () end) - (Hash) (struct type nonrec t = merkelized_and_payload diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index 8998b93dcf357..a7c3c81c81094 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -128,7 +128,7 @@ module Skip_list_parameters = struct let basis = 2 end -module Skip_list = Skip_list_repr.Make (Skip_list_parameters) +module Skip_list : Skip_list_repr.S = Skip_list_repr.Make (Skip_list_parameters) module V1 = struct type level_proof = { @@ -183,12 +183,25 @@ module V1 = struct (** Construct an inbox [history] with a given [capacity]. If you are running a rollup node, [capacity] needs to be large enough to remember any levels for which you may need to produce proofs. *) - module History = + module History : + Bounded_history_repr.S with type key = Hash.t and type value = history_proof = Bounded_history_repr.Make (struct let name = "inbox_history" + + let _sig_NAME = () + end) + (struct + type t = Hash.t + + let compare = Hash.compare + + let pp = Hash.pp + + let encoding = Hash.encoding + + let _sig_KEY = () end) - (Hash) (struct type t = history_proof @@ -855,7 +868,7 @@ let produce_proof ~get_level_tree_history history inbox_snapshot (l, n) = let result = Skip_list.search ~deref ~compare ~cell:inbox_snapshot in let* inc, history_proof = match result with - | Skip_list.{rev_path; last_cell = Found history_proof} -> + | {rev_path; last_cell = Found history_proof} -> return (List.rev rev_path, history_proof) | {last_cell = Nearest _; _} | {last_cell = No_exact_or_lower_ptr; _} diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index 3ab96e8ee9c5b..98839254f3f12 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -73,43 +73,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 -> tzfail 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 - ~elab_conf:Script_ir_translator_config.(make ~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 + ~elab_conf:Script_ir_translator_config.(make ~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_alpha/lib_protocol/sc_rollup_operations.ml b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml index e234e8c51057d..7506dcbe4f574 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml @@ -107,9 +107,13 @@ let origination_proof_of_string origination_proof kind = with type proof = Sc_rollup.ArithPVM.Protocol_implementation.proof) = (module struct - include Sc_rollup.ArithPVM.Protocol_implementation + include ( + Sc_rollup.ArithPVM.Protocol_implementation : + Sc_rollup_arith.S + with type proof = + Sc_rollup.ArithPVM.Protocol_implementation.proof) - let proof = proof + let proof_val = proof end) in return @@ Sc_rollup.Arith_pvm_with_proof (module PVM) @@ -130,9 +134,13 @@ let origination_proof_of_string origination_proof kind = with type proof = Sc_rollup.Wasm_2_0_0PVM.Protocol_implementation.proof) = (module struct - include Sc_rollup.Wasm_2_0_0PVM.Protocol_implementation + include ( + Sc_rollup.Wasm_2_0_0PVM.Protocol_implementation : + Sc_rollup_wasm.V2_0_0.S + with type proof = + Sc_rollup.Wasm_2_0_0PVM.Protocol_implementation.proof) - let proof = proof + let proof_val = proof end) in return @@ Sc_rollup.Wasm_2_0_0_pvm_with_proof (module PVM) @@ -187,7 +195,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 -> @@ -233,13 +241,13 @@ let check_origination_proof kind boot_sector origination_proof = Sc_rollup.Kind.name_of kind <> Sc_rollup.Kind.name_of kind') (Sc_rollup_proof_repr.Sc_rollup_proof_check "incorrect kind proof") in - let*! is_valid = PVM.verify_origination_proof PVM.proof boot_sector in + let*! is_valid = PVM.verify_origination_proof PVM.proof_val boot_sector in let* () = fail_when (not is_valid) (Sc_rollup_proof_repr.Sc_rollup_proof_check "invalid origination proof") in - return PVM.(proof_stop_state proof) + return PVM.(proof_stop_state proof_val) let originate ctxt ~kind ~boot_sector ~origination_proof ~parameters_ty = let open Lwt_result_syntax in @@ -343,8 +351,8 @@ let transfer_ticket_tokens ctxt ~source_destination ~acc_storage_diff (acc_storage_diff, ctxt) destinations -let validate_and_decode_output_proof ctxt ~cemented_commitment rollup - ~output_proof = +let[@coq_axiom_with_reason "TODO"] validate_and_decode_output_proof ctxt + ~cemented_commitment rollup ~output_proof = let open Lwt_result_syntax in (* Lookup the PVM of the rollup. *) let* ctxt, (module PVM : Sc_rollup.PVM.S) = @@ -405,7 +413,7 @@ let validate_outbox_level ctxt ~outbox_level ~lcc_level = (Raw_level.(outbox_level <= lcc_level) && outbox_level_is_active) Sc_rollup_invalid_outbox_level -let execute_outbox_message ctxt ~validate_and_decode_output_proof rollup +let execute_outbox_message_aux ctxt ~validate_and_decode_output_proof rollup ~cemented_commitment ~source ~output_proof = let open Lwt_result_syntax in (* TODO: #3211 @@ -496,10 +504,10 @@ let execute_outbox_message ctxt ~validate_and_decode_output_proof rollup return ({paid_storage_size_diff; operations}, ctxt) module Internal_for_tests = struct - let execute_outbox_message = execute_outbox_message + let execute_outbox_message = execute_outbox_message_aux let origination_proof_of_string = origination_proof_of_string end let execute_outbox_message ctxt = - execute_outbox_message ctxt ~validate_and_decode_output_proof + execute_outbox_message_aux ctxt ~validate_and_decode_output_proof diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml index 4dd15a754a49c..f4accd803d590 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -158,11 +158,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, and if it is at or below the origination level for this rollup. @@ -312,7 +312,7 @@ let valid ~metadata snapshot commit_level dal_snapshot dal_parameters let input = Option.bind input (cut_at_level ~origination_level ~commit_level) in - let* input_requested = P.verify_proof input P.proof in + let* input_requested = P.verify_proof input P.proof_val in let* () = match (proof.input_proof, input_requested) with | None, No_input_required -> return_unit @@ -354,8 +354,6 @@ module type PVM_with_context_and_state = sig val state : state - val proof_encoding : proof Data_encoding.t - val reveal : Sc_rollup_PVM_sig.Reveal_hash.t -> string option Lwt.t module Inbox_with_history : sig @@ -458,10 +456,10 @@ let produce ~metadata pvm_and_state commit_level = Option.bind input_given (cut_at_level ~origination_level ~commit_level) in let* pvm_step_proof = P.produce_proof P.context input_given P.state in - let module P_with_proof = struct + let module P_with_proof : Sc_rollups.PVM_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; input_proof} diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli index 652b28109f4e9..282b79531882a 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli @@ -153,8 +153,6 @@ module type PVM_with_context_and_state = sig val state : state - val proof_encoding : proof Data_encoding.t - val reveal : Sc_rollup_PVM_sig.Reveal_hash.t -> string option Lwt.t module Inbox_with_history : sig diff --git a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml index 8d67af2bafa4f..ec88c7fdd560c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml @@ -94,7 +94,7 @@ let get_ongoing_game_for_staker ctxt rollup staker = 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_result_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 @@ -149,7 +149,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 = @@ -239,11 +239,11 @@ let start_game ctxt rollup ~player:refuter ~opponent:defender = match (opp_1, opp_2) with | None, None -> return () | Some _refuter_opponent, None -> - tzfail (Sc_rollup_staker_in_game (`Refuter refuter)) + tzfail (Sc_rollup_staker_in_game (Refuter refuter)) | None, Some _defender_opponent -> - tzfail (Sc_rollup_staker_in_game (`Defender defender)) + tzfail (Sc_rollup_staker_in_game (Defender defender)) | Some _refuter_opponent, Some _defender_opponent -> - tzfail (Sc_rollup_staker_in_game (`Both (refuter, defender))) + tzfail (Sc_rollup_staker_in_game (Both (refuter, defender))) in let* ( ( {hash = _refuter_commit; commitment = _info}, {hash = _defender_commit; commitment = child_info} ), @@ -360,8 +360,8 @@ let reward ctxt winner = let*? reward = Tez_repr.(stake /? 2L) in Token.transfer ctxt - `Sc_rollup_refutation_rewards - (`Contract winner_contract) + (Source_infinite Sc_rollup_refutation_rewards) + (Sink_container (Contract winner_contract)) reward let apply_game_result ctxt rollup (stakers : Sc_rollup_game_repr.Index.t) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml index df431b7219a90..8e55f1da4132c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml @@ -101,9 +101,11 @@ module State_hash = struct context_hash_to_state_hash (without changing content of HASH.S) *) type unreachable = | - let hash_bytes = function (_ : unreachable) -> . + let[@coq_axiom_with_reason "unreachable expression"] hash_bytes = function + | (_ : unreachable) -> . - let hash_string = function (_ : unreachable) -> . + let[@coq_axiom_with_reason "unreachable expression"] hash_string = function + | (_ : unreachable) -> . end type t = Address.t @@ -133,9 +135,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_alpha/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml index 8784830939faf..e86d7bc3ee2a2 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml @@ -64,7 +64,7 @@ let deposit_stake ctxt rollup staker = let open Lwt_result_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) @@ -80,8 +80,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 @@ -105,8 +105,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 = @@ -262,7 +262,7 @@ let deallocate ctxt rollup node = let find_commitment_to_deallocate ctxt rollup commitment_hash ~num_commitments_to_keep = let open Lwt_result_syntax in - let rec aux ctxt commitment_hash n = + let[@coq_struct "n_value"] rec aux ctxt commitment_hash n = if Compare.Int.(n = 0) then return (Some commitment_hash, ctxt) else let* pred_hash, ctxt = @@ -305,7 +305,7 @@ let refine_stake ctxt rollup staker staked_on commitment = let*? ctxt, new_hash = Sc_rollup_commitment_storage.hash ctxt 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. *) @@ -468,15 +468,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_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index eb09ba5511623..4aa6fd08925a3 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/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 (** [address_from_nonce ctxt nonce] produces an address completely determined by an operation hash and an origination counter, and accounts for gas spent. *) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml index 9e19e92abac11..f45424a43b87a 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml @@ -24,15 +24,15 @@ (* *) (*****************************************************************************) -include Z +type t = Z.t -let initial = zero +let initial = Z.zero -let next = succ +let next = Z.succ -let jump tick z = max initial (add tick z) +let jump tick z = Z.max initial (Z.add tick z) -let pp = pp_print +let pp = Z.pp_print let encoding = Data_encoding.n @@ -47,16 +47,24 @@ let of_z x = x let of_number_of_ticks x = Z.of_int64 (Sc_rollup_repr.Number_of_ticks.to_value 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_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index ab131be41395e..cc5fd490ce1f6 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -96,13 +96,9 @@ module V2_0_0 = struct open Sc_rollup_repr module PS = Sc_rollup_PVM_sig - module type TreeS = - Context.TREE with type key = string list and type value = bytes - - module type Make_wasm = module type of Wasm_2_0_0.Make - module type P = sig - module Tree : TreeS + module Tree : + Context.TREE with type key = string list and type value = bytes type tree = Tree.tree @@ -151,7 +147,11 @@ module V2_0_0 = struct The Make_backend is a functor that creates the backend of the PVM. The Conext provides the tree and the proof types. *) - module Make (Make_backend : Make_wasm) (Context : P) : + module Make + (Make_backend : functor + (Tree : Context.TREE with type key = string list and type value = bytes) + -> Wasm_2_0_0.S with type tree := Tree.tree) + (Context : P) : S with type context = Context.Tree.t and type state = Context.tree @@ -164,11 +164,11 @@ module V2_0_0 = struct type proof = Context.proof - let proof_encoding = Context.proof_encoding + let proof_encoding : proof Data_encoding.t = Context.proof_encoding - let proof_start_state proof = Context.proof_before proof + let proof_start_state (proof : proof) = Context.proof_before proof - let proof_stop_state proof = Context.proof_after proof + let proof_stop_state (proof : proof) = Context.proof_after proof let name = "wasm_2_0_0" @@ -258,15 +258,15 @@ module V2_0_0 = struct let* s, _ = run m state in return s - let get_tick : Sc_rollup_tick_repr.t Monad.t = + let get_tick_aux : Sc_rollup_tick_repr.t Monad.t = let open Monad.Syntax in let* s = get in let* info = lift (WASM_machine.get_info s) in return @@ Sc_rollup_tick_repr.of_z info.current_tick - let get_tick : state -> Sc_rollup_tick_repr.t Lwt.t = result_of get_tick + let get_tick : state -> Sc_rollup_tick_repr.t Lwt.t = result_of get_tick_aux - let get_status : status Monad.t = + let get_status_aux : status Monad.t = let open Monad.Syntax in let open Sc_rollup_PVM_sig in let* s = get in @@ -302,9 +302,9 @@ module V2_0_0 = struct Some (inbox_level, message_counter) | _ -> None - let is_input_state = + let is_input_state_aux = let open Monad.Syntax in - let* status = get_status in + let* status = get_status_aux in match status with | Waiting_for_input_message -> ( let* last_read = get_last_message_read in @@ -314,9 +314,9 @@ module V2_0_0 = struct | Computing -> return PS.No_input_required | Waiting_for_reveal reveal -> return (PS.Needs_reveal reveal) - let is_input_state = result_of is_input_state + let is_input_state = result_of is_input_state_aux - let get_status : state -> status Lwt.t = result_of get_status + let get_status : state -> status Lwt.t = result_of get_status_aux let get_outbox outbox_level state = let outbox_level_int32 = @@ -409,14 +409,14 @@ module V2_0_0 = struct in return (state, request) - let verify_proof input_given proof = + let verify_proof input_given (proof : proof) = let open Lwt_result_syntax in let*! result = Context.verify_proof proof (step_transition input_given) in match result with | None -> tzfail WASM_proof_verification_failed | Some (_state, request) -> return request - let produce_proof context input_given state = + let produce_proof context input_given state : proof tzresult Lwt.t = let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) @@ -425,7 +425,7 @@ module V2_0_0 = struct | Some (tree_proof, _requested) -> return tree_proof | None -> tzfail WASM_proof_production_failed - let verify_origination_proof proof boot_sector = + let verify_origination_proof (proof : proof) boot_sector = let open Lwt_syntax in let before = Context.proof_before proof in if State_hash.(before <> reference_initial_state_hash) then return false @@ -437,7 +437,7 @@ module V2_0_0 = struct in match result with None -> return false | Some (_, ()) -> return true - let produce_origination_proof context boot_sector = + let produce_origination_proof context boot_sector : proof tzresult Lwt.t = let open Lwt_result_syntax in let*! state = initial_state ~empty:(Tree.empty context) in let*! result = @@ -553,7 +553,8 @@ module V2_0_0 = struct (* Can't produce proof without full context*) Lwt.return None - let kinded_hash_to_state_hash = function + let kinded_hash_to_state_hash : Context.Proof.kinded_hash -> _ = + function | `Value hash | `Node hash -> State_hash.context_hash_to_state_hash hash diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.mli b/src/proto_alpha/lib_protocol/sc_rollup_wasm.mli index 3d42188d8863f..9f91df28123d9 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.mli @@ -88,10 +88,12 @@ module V2_0_0 : sig Tree.t -> tree -> (tree -> (tree * 'a) Lwt.t) -> (proof * 'a) option Lwt.t end - module type Make_wasm = module type of Wasm_2_0_0.Make - (** Build a WebAssembly PVM using the given proof-supporting context. *) - module Make (Lib_scoru_Wasm : Make_wasm) (Context : P) : + module Make + (Lib_scoru_Wasm : functor + (Tree : Context.TREE with type key = string list and type value = bytes) + -> Wasm_2_0_0.S with type tree := Tree.tree) + (Context : P) : S with type context = Context.Tree.t and type state = Context.tree diff --git a/src/proto_alpha/lib_protocol/sc_rollups.ml b/src/proto_alpha/lib_protocol/sc_rollups.ml index 3d1c7c79bee3e..9d730b6fa9b53 100644 --- a/src/proto_alpha/lib_protocol/sc_rollups.ml +++ b/src/proto_alpha/lib_protocol/sc_rollups.ml @@ -105,7 +105,7 @@ end module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end type wrapped_proof = @@ -120,8 +120,16 @@ type wrapped_proof = let wrapped_proof_module p = match p with | Unencodable p -> p - | Arith_pvm_with_proof (module P) -> (module P) - | Wasm_2_0_0_pvm_with_proof (module P) -> (module P) + | Arith_pvm_with_proof p -> + let (module P) = p in + (module struct + include P + end : PVM_with_proof) + | Wasm_2_0_0_pvm_with_proof p -> + let (module P) = p in + (module struct + include P + end : PVM_with_proof) let wrapped_proof_kind_exn : wrapped_proof -> Kind.t = function | Unencodable _ -> @@ -147,13 +155,14 @@ let wrapped_proof_encoding = "proof" Sc_rollup_arith.Protocol_implementation.proof_encoding)) (function - | Arith_pvm_with_proof (module P) -> Some ((), P.proof) | _ -> None) + | Arith_pvm_with_proof (module P) -> Some ((), P.proof_val) + | _ -> None) (fun ((), proof) -> Arith_pvm_with_proof (module struct include Sc_rollup_arith.Protocol_implementation - let proof = proof + let proof_val = proof end)); case ~title:"Wasm 2.0.0 PVM with proof" @@ -164,14 +173,20 @@ let wrapped_proof_encoding = "proof" Sc_rollup_wasm.V2_0_0.Protocol_implementation.proof_encoding)) (function - | Wasm_2_0_0_pvm_with_proof (module P) -> Some ((), P.proof) + | Wasm_2_0_0_pvm_with_proof pvm -> + let (module P : PVM_with_proof + with type proof = + Sc_rollup_wasm.V2_0_0.Protocol_implementation.proof) = + pvm + in + Some ((), P.proof_val) | _ -> None) (fun ((), proof) -> Wasm_2_0_0_pvm_with_proof (module struct include Sc_rollup_wasm.V2_0_0.Protocol_implementation - let proof = proof + let proof_val = proof end)); (* The later case is provided solely in order to provide error messages in case someone tries to encode an [Unencodable] @@ -199,14 +214,17 @@ let wrap_proof pvm_with_proof = | Some Kind.Example_arith -> Option.map (fun arith_proof -> - let module P_arith = struct + let module P_arith : + PVM_with_proof + with type proof = Sc_rollup_arith.Protocol_implementation.proof = + struct include Sc_rollup_arith.Protocol_implementation - 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.Protocol_implementation.proof_encoding @@ -214,14 +232,17 @@ let wrap_proof pvm_with_proof = | Some Kind.Wasm_2_0_0 -> Option.map (fun wasm_proof -> - let module P_wasm2_0_0 = struct + let module P_wasm2_0_0 : + PVM_with_proof + with type proof = + Sc_rollup_wasm.V2_0_0.Protocol_implementation.proof = struct include Sc_rollup_wasm.V2_0_0.Protocol_implementation - 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.Protocol_implementation.proof_encoding diff --git a/src/proto_alpha/lib_protocol/sc_rollups.mli b/src/proto_alpha/lib_protocol/sc_rollups.mli index e76d7976fa4ff..236d8a4196f7a 100644 --- a/src/proto_alpha/lib_protocol/sc_rollups.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index a149b8e569a27..14c0f63b8a9e7 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/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 - ~elab_conf:Script_ir_translator_config.(make ~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 + ~elab_conf:Script_ir_translator_config.(make ~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_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index 2156d26610b5e..391495985f44a 100644 --- a/src/proto_alpha/lib_protocol/script_comparable.ml +++ b/src/proto_alpha/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,5 +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 +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_alpha/lib_protocol/script_int.ml b/src/proto_alpha/lib_protocol/script_int.ml index a2ef0ebc257e9..5d06c29b734ed 100644 --- a/src/proto_alpha/lib_protocol/script_int.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/script_int.mli b/src/proto_alpha/lib_protocol/script_int.mli index 449192a3cc59a..abe121d78ca58 100644 --- a/src/proto_alpha/lib_protocol/script_int.mli +++ b/src/proto_alpha/lib_protocol/script_int.mli @@ -34,7 +34,7 @@ type 't repr (** [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_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 1a3d93551e595..8ada8db595f06 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1657,7 +1657,7 @@ open Raw 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 -> @@ -1868,7 +1868,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 -> @@ -2406,7 +2406,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 = { @@ -2431,18 +2431,18 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal | None -> parse_script ctxt unparsed_script ~elab_conf ~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 @@ -2452,9 +2452,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) @@ -2476,7 +2480,9 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal storage_type new_storage >>=? fun (storage, lazy_storage_diff, ctxt) -> - trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage) + trace + Cannot_serialize_storage + ((unparse_data [@coq_type_annotation]) ctxt mode storage_type storage) >>=? fun (unparsed_storage, ctxt) -> let op_to_couple op = (op.piop, op.lazy_storage_diff) in let operations, op_diffs = diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 01cc37bb2b8d7..8c847f2943e53 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -71,313 +71,289 @@ 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 : _ Script_list.t), _ -> Interp_costs.list_map list + | IList_iter _, (list : _ Script_list.t), _ -> 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 : _ Script_list.t), _ -> Interp_costs.concat_string_precheck ss - | ISlice_string _ -> - let (_offset : Script_int.n Script_int.num) = 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 : _ Script_list.t), _ -> 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 - | ILsl_bytes _ -> + | ILsl_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsl_nat x + | ILsl_bytes _, _, _ -> let x = accu in let y, _ = stack in Interp_costs.lsl_bytes x y - | ILsr_nat _ -> - let x = accu in - Interp_costs.lsr_nat x - | ILsr_bytes _ -> + | ILsr_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsr_nat x + | ILsr_bytes _, _, _ -> let x = accu in let y, _ = stack in Interp_costs.lsr_bytes x y - | IOr_nat _ -> - let x = accu and y, _ = stack in + | IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.or_nat x y - | IOr_bytes _ -> + | IOr_bytes _, _, _ -> let x = accu and y, _ = stack in Interp_costs.or_bytes 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 - | IAnd_bytes _ -> + | IAnd_bytes _, _, _ -> let x = accu and y, _ = stack in Interp_costs.and_bytes 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 - | IXor_bytes _ -> + | IXor_bytes _, _, _ -> let x = accu and y, _ = stack in Interp_costs.xor_bytes x y - | INot_int _ -> - let x = accu in - Interp_costs.not_int x - | INot_bytes _ -> + | INot_int _, (x : _ Script_int.num), _ -> Interp_costs.not_int x + | INot_bytes _, _, _ -> let x = accu in Interp_costs.not_bytes x - | ICompare (_, ty, _) -> - let a = accu and b, _ = stack in + | 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 : _ Script_list.t), _ -> 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 _ -> + | ISplit_ticket _, _, (stack : (_ * _) * _) -> let (amount_a, amount_b), _ = stack in Interp_costs.split_ticket amount_a amount_b - | IJoin_tickets (_, ty, _) -> + | IJoin_tickets (_, ty, _), (accu : _ ticket * _ ticket), _ -> let ticket_a, ticket_b = accu in Interp_costs.join_tickets ty ticket_a ticket_b - | IHalt _ -> Interp_costs.halt - | IDrop _ -> Interp_costs.drop - | IDup _ -> Interp_costs.dup - | ISwap _ -> Interp_costs.swap - | IConst _ -> Interp_costs.const - | ICons_some _ -> Interp_costs.cons_some - | ICons_none _ -> Interp_costs.cons_none - | IIf_none _ -> Interp_costs.if_none - | IOpt_map _ -> Interp_costs.opt_map - | ICons_pair _ -> Interp_costs.cons_pair - | IUnpair _ -> Interp_costs.unpair - | ICar _ -> Interp_costs.car - | ICdr _ -> Interp_costs.cdr - | ICons_left _ -> Interp_costs.cons_left - | ICons_right _ -> Interp_costs.cons_right - | IIf_left _ -> Interp_costs.if_left - | ICons_list _ -> Interp_costs.cons_list - | INil _ -> Interp_costs.nil - | IIf_cons _ -> Interp_costs.if_cons - | IList_size _ -> Interp_costs.list_size - | IEmpty_set _ -> Interp_costs.empty_set - | ISet_size _ -> Interp_costs.set_size - | IEmpty_map _ -> Interp_costs.empty_map - | IMap_size _ -> Interp_costs.map_size - | IEmpty_big_map _ -> Interp_costs.empty_big_map - | IString_size _ -> Interp_costs.string_size - | IBytes_size _ -> Interp_costs.bytes_size - | IAdd_tez _ -> Interp_costs.add_tez - | ISub_tez _ -> Interp_costs.sub_tez - | ISub_tez_legacy _ -> Interp_costs.sub_tez_legacy - | IOr _ -> Interp_costs.bool_or - | IAnd _ -> Interp_costs.bool_and - | IXor _ -> Interp_costs.bool_xor - | INot _ -> Interp_costs.bool_not - | IIs_nat _ -> Interp_costs.is_nat - | IInt_nat _ -> Interp_costs.int_nat - | IInt_bls12_381_fr _ -> Interp_costs.int_bls12_381_fr - | IEdiv_tez _ -> Interp_costs.ediv_tez - | IIf _ -> Interp_costs.if_ - | ILoop _ -> Interp_costs.loop - | ILoop_left _ -> Interp_costs.loop_left - | IDip _ -> Interp_costs.dip - | IExec _ -> Interp_costs.exec - | IApply _ -> ( + | 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 _, _, (stack : _ lambda * _) -> ( let l, _ = stack in match l with | Lam _ -> Interp_costs.apply ~rec_flag:false | LamRec _ -> Interp_costs.apply ~rec_flag:true) - | ILambda _ -> Interp_costs.lambda - | IFailwith _ -> Gas.free - | IEq _ -> Interp_costs.eq - | INeq _ -> Interp_costs.neq - | ILt _ -> Interp_costs.lt - | ILe _ -> Interp_costs.le - | IGt _ -> Interp_costs.gt - | IGe _ -> Interp_costs.ge - | IPack _ -> Gas.free - | IUnpack _ -> + | 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 _ | ITicket_deprecated _ -> Interp_costs.ticket - | IRead_ticket _ -> Interp_costs.read_ticket - | IOpen_chest _ -> - let (_chest_key : Script_timelock.chest_key) = accu - and chest, (time, _) = stack in + | IDup_n (_, n, _, _), _, _ -> Interp_costs.dupn n + | IComb (_, n, _, _), _, _ -> Interp_costs.comb n + | IUncomb (_, n, _, _), _, _ -> Interp_costs.uncomb n + | IComb_get (_, n, _, _), _, _ -> Interp_costs.comb_get n + | IComb_set (_, n, _, _), _, _ -> Interp_costs.comb_set n + | (ITicket _ | ITicket_deprecated _), _, _ -> Interp_costs.ticket + | IRead_ticket _, _, _ -> Interp_costs.read_ticket + | IOpen_chest _, _, (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] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = @@ -435,7 +411,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 -> @@ -443,12 +419,12 @@ 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]. *) @@ -468,76 +444,79 @@ let apply ctxt gas capture_ty capture lam = let lam' = match lam with | LamRec (descr, expr) -> ( - let (Item_t (full_arg_ty, Item_t (Lambda_t (_, _, _), Bot_t))) = - descr.kbef - in - let (Item_t (ret_ty, Bot_t)) = descr.kaft in - Script_ir_unparser.unparse_ty ~loc ctxt full_arg_ty - >>?= fun (arg_ty_expr, ctxt) -> - Script_ir_unparser.unparse_ty ~loc ctxt ret_ty - >>?= fun (ret_ty_expr, ctxt) -> - match full_arg_ty with - | Pair_t (capture_ty, arg_ty, _, _) -> - let arg_stack_ty = Item_t (arg_ty, Bot_t) in - (* To avoid duplicating the recursive lambda [lam], we - return a regular lambda that builds the tuple of - parameters and applies it to `lam`. Since `lam` is - recursive it will push itself on top of the stack at - execution time. *) - let full_descr = - { - kloc = descr.kloc; - kbef = arg_stack_ty; - kaft = descr.kaft; - kinstr = - IConst - ( descr.kloc, - capture_ty, - capture, - ICons_pair + match[@coq_match_with_default] (descr.kbef, descr.kaft) with + | ( Item_t (full_arg_ty, Item_t (Lambda_t (_, _, _), Bot_t)), + Item_t (ret_ty, Bot_t) ) -> ( + Script_ir_unparser.unparse_ty ~loc ctxt full_arg_ty + >>?= fun (arg_ty_expr, ctxt) -> + Script_ir_unparser.unparse_ty ~loc ctxt ret_ty + >>?= fun (ret_ty_expr, ctxt) -> + match[@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 + (* To avoid duplicating the recursive lambda [lam], we + return a regular lambda that builds the tuple of + parameters and applies it to `lam`. Since `lam` is + recursive it will push itself on top of the stack at + execution time. *) + let full_descr = + { + kloc = descr.kloc; + kbef = arg_stack_ty; + kaft = descr.kaft; + kinstr = + IConst ( descr.kloc, - ILambda + capture_ty, + capture, + ICons_pair ( descr.kloc, - lam, - ISwap + ILambda ( descr.kloc, - IExec + lam, + ISwap ( descr.kloc, - Some descr.kaft, - IHalt descr.kloc ) ) ) ) ); - } - in - let full_expr = - make_expr - Micheline. - [ - Prim - (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; expr], []); - Prim (loc, I_SWAP, [], []); - Prim (loc, I_EXEC, [], []); - ] - in - return (Lam (full_descr, full_expr), ctxt)) + IExec + ( descr.kloc, + Some descr.kaft, + IHalt descr.kloc ) ) ) ) ); + } + in + let full_expr = + make_expr + Micheline. + [ + Prim + ( loc, + I_LAMBDA_REC, + [arg_ty_expr; ret_ty_expr; expr], + [] ); + Prim (loc, I_SWAP, [], []); + Prim (loc, I_EXEC, [], []); + ] + in + return (Lam (full_descr, full_expr), ctxt))) | Lam (descr, expr) -> ( - let (Item_t (full_arg_ty, Bot_t)) = descr.kbef in - match full_arg_ty with - | Pair_t (capture_ty, arg_ty, _, _) -> - let arg_stack_ty = Item_t (arg_ty, Bot_t) in - let full_descr = - { - kloc = descr.kloc; - kbef = arg_stack_ty; - kaft = descr.kaft; - kinstr = - IConst - ( descr.kloc, - capture_ty, - capture, - ICons_pair (descr.kloc, descr.kinstr) ); - } - in - let full_expr = make_expr [expr] in - return (Lam (full_descr, full_expr), ctxt)) + match[@coq_match_with_default] descr.kbef with + | Item_t (full_arg_ty, Bot_t) -> ( + 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 = + IConst + ( descr.kloc, + capture_ty, + capture, + ICons_pair (descr.kloc, descr.kinstr) ); + } + in + let full_expr = make_expr [expr] in + return (Lam (full_descr, full_expr), ctxt))) in lam' >>=? fun (lam', ctxt) -> let gas, ctxt = local_gas_counter_and_outdated_context ctxt in @@ -559,22 +538,26 @@ let make_transaction_to_tx_rollup (type t) ctxt ~destination ~amount the type of the ticket. *) error_unless Tez.(amount = zero) Rollup_invalid_transaction_amount >>?= fun () -> - let (Pair_t (Ticket_t (tp, _), _, _, _)) = parameters_ty in - unparse_data ctxt Optimized parameters_ty parameters - >>=? fun (unparsed_parameters, ctxt) -> - Lwt.return - ( Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt tp - >>? fun (ty, ctxt) -> - let unparsed_parameters = - Micheline.Seq - (Micheline.dummy_location, [Micheline.root unparsed_parameters; ty]) - in - Gas.consume ctxt (Script.strip_locations_cost unparsed_parameters) - >|? fun ctxt -> - let unparsed_parameters = Micheline.strip_locations unparsed_parameters in - ( Transaction_to_tx_rollup - {destination; parameters_ty; parameters; unparsed_parameters}, - ctxt ) ) + match[@coq_match_with_default] parameters_ty with + | Pair_t (Ticket_t (tp, _), _, _, _) -> + unparse_data ctxt Optimized parameters_ty parameters + >>=? fun (unparsed_parameters, ctxt) -> + Lwt.return + ( Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt tp + >>? fun (ty, ctxt) -> + let unparsed_parameters = + Micheline.Seq + ( Micheline.dummy_location, + [Micheline.root unparsed_parameters; ty] ) + in + Gas.consume ctxt (Script.strip_locations_cost unparsed_parameters) + >|? fun ctxt -> + let unparsed_parameters = + Micheline.strip_locations unparsed_parameters + in + ( Transaction_to_tx_rollup + {destination; parameters_ty; parameters; unparsed_parameters}, + ctxt ) ) let make_transaction_to_sc_rollup ctxt ~destination ~amount ~entrypoint ~parameters_ty ~parameters = @@ -619,12 +602,13 @@ let make_transaction_to_zk_rollup (type t) ctxt ~destination ~amount let transfer (type t) (ctxt, sc) gas amount location (typed_contract : t typed_contract) (parameters : t) = let ctxt = update_context gas ctxt in - (match typed_contract with - | Typed_implicit destination -> + (match[@coq_match_gadt] (typed_contract, parameters) with + | Typed_implicit destination, (parameters : unit) -> let () = parameters in return (Transaction_to_implicit {destination; amount}, None, ctxt) - | Typed_originated - {arg_ty = parameters_ty; contract_hash = destination; entrypoint} -> + | ( Typed_originated + {arg_ty = parameters_ty; contract_hash = destination; entrypoint}, + _ ) -> collect_lazy_storage ctxt parameters_ty parameters >>?= fun (to_duplicate, ctxt) -> let to_update = no_lazy_storage_id in @@ -651,7 +635,8 @@ let transfer (type t) (ctxt, sc) gas amount location }, lazy_storage_diff, ctxt ) - | Typed_tx_rollup {arg_ty = parameters_ty; tx_rollup = destination} -> + | ( Typed_tx_rollup {arg_ty = parameters_ty; tx_rollup = destination}, + (parameters : (_ ticket, tx_rollup_l2_address) pair) ) -> make_transaction_to_tx_rollup ctxt ~destination @@ -659,8 +644,9 @@ let transfer (type t) (ctxt, sc) gas amount location ~parameters_ty ~parameters >|=? fun (operation, ctxt) -> (operation, None, ctxt) - | Typed_sc_rollup - {arg_ty = parameters_ty; sc_rollup = destination; entrypoint} -> + | ( Typed_sc_rollup + {arg_ty = parameters_ty; sc_rollup = destination; entrypoint}, + _ ) -> make_transaction_to_sc_rollup ctxt ~destination @@ -669,7 +655,8 @@ let transfer (type t) (ctxt, sc) gas amount location ~parameters_ty ~parameters >|=? fun (operation, ctxt) -> (operation, None, ctxt) - | Typed_zk_rollup {arg_ty = parameters_ty; zk_rollup = destination} -> + | ( Typed_zk_rollup {arg_ty = parameters_ty; zk_rollup = destination}, + (parameters : _ ticket * bytes) ) -> make_transaction_to_zk_rollup ctxt ~destination @@ -758,7 +745,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 -> @@ -766,11 +753,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_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 6c477246b4673..2ba87f156b31f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 80ec18fbe31f0..ee3bfcf2510f5 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -174,10 +174,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 _ -> @@ -223,13 +224,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 @@ -271,7 +272,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)) @@ -300,27 +301,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 @@ -432,9 +424,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 + |> 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 @@ -467,6 +463,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) ----------------------*) @@ -510,7 +507,7 @@ let parse_memo_size (n : (location, _) Micheline.node) : match n with | Int (_, z) -> ( match Sapling.Memo_size.parse_z z with - | Ok _ as ok_memo_size -> ok_memo_size + | Ok memo_size -> Ok memo_size | Error msg -> error @@ Invalid_syntactic_constant (location n, strip_locations n, msg)) @@ -526,13 +523,13 @@ 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 + In the second case, use [~ret:Parse_entrypoints], [parse_ty_aux] will return an [ex_parameter_ty_and_entrypoints_node]. *) type ('ret, 'name) parse_ty_ret = @@ -540,7 +537,7 @@ type ('ret, 'name) parse_ty_ret = | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let rec parse_ty : +let[@coq_struct "node_value"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -566,13 +563,13 @@ let 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 @@ -637,7 +634,7 @@ let 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 @@ -649,7 +646,7 @@ let 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 @@ -666,7 +663,7 @@ let 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 @@ -686,7 +683,7 @@ let 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 @@ -697,7 +694,7 @@ let rec parse_ty : ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -709,12 +706,15 @@ let 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 @@ -733,9 +733,9 @@ let 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 @@ -746,7 +746,7 @@ let 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 @@ -759,7 +759,7 @@ let 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 @@ -774,20 +774,20 @@ let 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 @@ -811,11 +811,11 @@ let 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 @@ -884,13 +884,13 @@ let rec parse_ty : T_unit; ] -and 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) @@ -907,7 +907,7 @@ and parse_comparable_ty : error (Comparable_type_expected (location node, Micheline.strip_locations node)) -and parse_passable_ty : +and[@coq_struct "stack_depth"] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -916,7 +916,7 @@ and parse_passable_ty : Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -925,14 +925,14 @@ and parse_passable_ty : ~allow_contract:true ~allow_ticket:true -and parse_any_ty : +and[@coq_struct "stack_depth"] parse_any_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -942,13 +942,14 @@ and parse_any_ty : ~allow_ticket:true ~ret:Don't_parse_entrypoints -and parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc args map_annot = +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 @@ -959,8 +960,9 @@ and parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc args map_annot = (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and parse_big_map_value_ty ctxt ~stack_depth ~legacy value_ty = - (parse_ty [@tailcall]) +and[@coq_struct "stack_depth"] parse_big_map_value_ty_aux ctxt ~stack_depth + ~legacy value_ty = + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -971,8 +973,8 @@ and parse_big_map_value_ty ctxt ~stack_depth ~legacy value_ty = ~ret:Don't_parse_entrypoints value_ty -let parse_packable_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) +let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -986,7 +988,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 @@ -998,7 +1000,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 @@ -1010,7 +1012,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 @@ -1125,6 +1127,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 @@ -1138,6 +1141,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 @@ -1182,16 +1186,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. @@ -1260,7 +1267,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 -> @@ -1268,26 +1275,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 @@ -1300,7 +1316,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) @@ -1309,7 +1325,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 @@ -1387,14 +1409,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 @@ -1408,7 +1430,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)) ; @@ -1755,7 +1778,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) @@ -1771,7 +1794,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, [])) @@ -1868,7 +1891,7 @@ let parse_toplevel : (* 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 @@ -1878,7 +1901,7 @@ let parse_toplevel : - storage after origination *) -let rec parse_data : +let[@coq_struct "ctxt"] rec parse_data_aux : type a ac. elab_conf:elab_conf -> stack_depth:int -> @@ -1893,7 +1916,7 @@ let rec parse_data : if Compare.Int.(stack_depth > 10_000) then tzfail Typechecking_too_many_recursive_calls else - parse_data + parse_data_aux ~elab_conf ~stack_depth:(stack_depth + 1) ctxt @@ -2016,7 +2039,7 @@ let rec parse_data : >|=? fun (_, map, ctxt) -> (map, ctxt) in let legacy = elab_conf.legacy 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) @@ -2044,7 +2067,7 @@ let 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 @@ -2089,7 +2112,8 @@ let rec parse_data : lambda_rec_ty 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 = non_terminal_recursion ctxt t v in @@ -2104,7 +2128,8 @@ let 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 @@ -2114,7 +2139,14 @@ let rec parse_data : match Ticket_amount.of_n amount with | Some amount -> ( 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 _ | Zk_rollup _ -> tzfail (Unexpected_ticket_owner destination)) | None -> traced_fail Forbidden_zero_ticket_quantity @@ -2151,16 +2183,21 @@ let 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 ctxt expr tk tv vs (fun x -> x) + ((parse_items [@coq_type_annotation]) 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 ctxt expr tk tv vs (fun x -> Some x) >|=? fun (diff, ctxt) -> (None, diff, ctxt) @@ -2188,12 +2225,12 @@ let 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 @@ -2218,14 +2255,16 @@ let 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 @@ -2235,7 +2274,8 @@ let 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]. @@ -2257,7 +2297,8 @@ let 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 @@ -2276,7 +2317,8 @@ let 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 @@ -2290,11 +2332,12 @@ let 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) -> ( @@ -2307,7 +2350,8 @@ let 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 -> @@ -2317,9 +2361,10 @@ let 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. elab_conf:elab_conf -> context -> @@ -2343,7 +2388,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 ~elab_conf ~stack_depth:0 Tc_context.view @@ -2382,7 +2427,7 @@ and parse_view : ctxt ) | _ -> error (ill_type_view aft loc)) -and parse_views : +and[@coq_mutual_as_notation] parse_views : type storage storagec. elab_conf:elab_conf -> context -> @@ -2398,7 +2443,7 @@ and parse_views : in Script_map.map_es_in_context aux ctxt views -and parse_kdescr : +and[@coq_mutual_as_notation] parse_kdescr : type arg argc ret retc. elab_conf:elab_conf -> stack_depth:int -> @@ -2409,7 +2454,7 @@ and parse_kdescr : Script.node -> ((arg, end_of_stack, ret, end_of_stack) kdescr * context) tzresult Lwt.t = fun ~elab_conf ~stack_depth tc_context ctxt arg ret script_instr -> - parse_instr + parse_instr_aux ~elab_conf tc_context ctxt @@ -2440,7 +2485,7 @@ and parse_kdescr : : (arg, end_of_stack, ret, end_of_stack) kdescr), ctxt ) -and parse_lam_rec : +and[@coq_mutual_as_notation] parse_lam_rec : type arg argc ret retc. elab_conf:elab_conf -> stack_depth:int -> @@ -2452,7 +2497,7 @@ and parse_lam_rec : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ~elab_conf ~stack_depth tc_context ctxt arg ret lambda_rec_ty script_instr -> - parse_instr + parse_instr_aux ~elab_conf tc_context ctxt @@ -2482,7 +2527,7 @@ and parse_lam_rec : : (arg, ret) lambda), ctxt ) -and parse_instr : +and[@coq_struct "ctxt"] parse_instr_aux : type a s. elab_conf:elab_conf -> stack_depth:int -> @@ -2529,7 +2574,7 @@ and parse_instr : if Compare.Int.(stack_depth > 10000) then tzfail Typechecking_too_many_recursive_calls else - parse_instr + parse_instr_aux ~elab_conf tc_context ctxt @@ -2661,9 +2706,9 @@ and 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 ~elab_conf ~stack_depth:(stack_depth + 1) ctxt @@ -2671,7 +2716,9 @@ and 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 () -> @@ -2683,7 +2730,7 @@ and 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 @@ -2754,8 +2801,9 @@ and 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 @@ -2770,7 +2818,7 @@ and 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 = @@ -2829,7 +2877,7 @@ and 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 @@ -2837,7 +2885,7 @@ and 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 @@ -2869,7 +2917,7 @@ and 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 @@ -2971,7 +3019,7 @@ and 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 @@ -3024,9 +3072,9 @@ and 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 = @@ -3138,9 +3186,9 @@ and 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 @@ -3354,9 +3402,9 @@ and 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 () -> @@ -3375,9 +3423,9 @@ and parse_instr : typed ctxt loc instr stack | ( Prim (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; lambda_expr], annot), stack ) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] lambda_expr >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -3833,7 +3881,7 @@ and 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) -> @@ -3858,7 +3906,7 @@ and 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 -> @@ -3872,7 +3920,7 @@ and 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 -> @@ -3933,11 +3981,11 @@ and 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 @@ -3965,7 +4013,7 @@ and parse_instr : arg_type_full ret_type_full code_field) - >>=? function + >>=? function[@coq_match_with_default] | {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, ctxt -> let views_result = parse_views ctxt ~elab_conf storage_type views in trace (Ill_typed_contract (canonical_code, [])) views_result @@ -4045,7 +4093,7 @@ and 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)) @@ -4058,11 +4106,11 @@ and 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 -> @@ -4265,7 +4313,7 @@ and 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 -> @@ -4476,27 +4524,6 @@ and parse_instr : I_XOR; ] -and 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]). @@ -4508,7 +4535,7 @@ and parse_contract_data : The inner [result] is turned into an [option] by [parse_contract_for_script]. Both [tzresult] are merged by [parse_contract_data]. *) -and parse_contract : +and[@coq_mutual_as_notation] parse_contract : type arg argc err. stack_depth:int -> context -> @@ -4522,7 +4549,7 @@ and parse_contract : 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 @@ -4557,18 +4584,20 @@ and parse_contract : 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 @@ -4621,16 +4650,17 @@ and parse_contract : 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 @@ -4641,6 +4671,27 @@ and parse_contract : entrypoint_arg >|? fun (entrypoint, arg_ty) -> Typed_sc_rollup {arg_ty; sc_rollup; entrypoint} )) +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. @@ -4698,12 +4749,16 @@ let parse_code : >>?= fun (code, ctxt) -> let legacy = elab_conf.legacy in 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 @@ -4750,7 +4805,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 ~elab_conf ~stack_depth:0 ctxt @@ -4766,10 +4821,17 @@ let parse_script : (ex_script * context) tzresult Lwt.t = fun ~elab_conf ctxt ~allow_forged_in_storage {code; storage} -> parse_code ~elab_conf ctxt ~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 ~elab_conf ctxt @@ -4779,7 +4841,15 @@ let 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 = @@ -4793,7 +4863,7 @@ type typechecked_code_internal = } -> typechecked_code_internal -let typecheck_code : +let typecheck_code_aux : legacy:bool -> show_types:bool -> context -> @@ -4802,13 +4872,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 @@ -4898,13 +4972,17 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) in fold_tree full entrypoints.root [] reachable ([], init) -include Data_unparser (struct +module Michelson_Parser = struct let opened_ticket_type = opened_ticket_type - let parse_packable_ty = parse_packable_ty + let parse_packable_ty_aux = parse_packable_ty_aux - let parse_data = parse_data -end) + let parse_data_aux = parse_data_aux +end + +module Data_unparser_Michelson = Data_unparser (Michelson_Parser) +module Internal_for_benchmarking = + Data_unparser_Michelson.Internal_for_benchmarking let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage mode ~normalize_types {code; storage} = @@ -4913,7 +4991,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 = @@ -4937,8 +5015,14 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~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 + Data_unparser_Michelson.unparse_code_aux ctxt ~stack_depth:0 mode code_field + >>=? fun (code, ctxt) -> + (Data_unparser_Michelson.unparse_data_aux [@coq_implicit "a" "a"]) + ctxt + ~stack_depth:0 + mode + storage_type + storage >>=? fun (storage, ctxt) -> let loc = Micheline.dummy_location in (if normalize_types then @@ -4960,7 +5044,11 @@ 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 + Data_unparser_Michelson.unparse_code_aux + ctxt + ~stack_depth:0 + mode + view_code >|=? fun (view_code, ctxt) -> let view_code = Micheline.root view_code in ({input_ty; output_ty; view_code}, ctxt)) @@ -4997,8 +5085,8 @@ 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) -> - pack_node unparsed ctxt + Data_unparser_Michelson.unparse_data_aux ~stack_depth:0 ctxt mode ty data + >|=? fun (unparsed, ctxt) -> pack_node unparsed ctxt let hash_data ctxt ty data = pack_data_with_mode ctxt ty data ~mode:Optimized_legacy @@ -5014,54 +5102,61 @@ 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 ctxt mode key_type key >>=? fun (key, ctxt) -> - (match value with - | None -> return (None, ctxt) - | Some x -> - unparse_data ~stack_depth:0 ctxt mode value_type x - >|=? fun (node, ctxt) -> (Some 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) + (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 + (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 ctxt mode key_type key >>=? fun (key, ctxt) -> + (match value with + | None -> return (None, ctxt) + | Some x -> + Data_unparser_Michelson.unparse_data_aux + ~stack_depth:0 + ctxt + mode + value_type + x + >|=? fun (node, ctxt) -> (Some 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) = @@ -5078,21 +5173,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 @@ -5109,11 +5204,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 = @@ -5169,7 +5264,7 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = *) let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = - let rec aux : + let[@coq_struct "has_lazy_storage_value"] rec aux : type a ac. context -> unparsing_mode -> @@ -5182,9 +5277,11 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = (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 = @@ -5199,7 +5296,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = 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 = @@ -5208,22 +5305,48 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = 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 : _ Script_list.t) -> 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 @@ -5234,7 +5357,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = >|=? fun (ctxt, l, ids_to_copy, acc) -> let reversed = Script_list.rev l 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 @@ -5245,7 +5368,8 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = (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 @@ -5255,6 +5379,8 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let boxed = m let size = M.size + + let boxed_map_tag = () end in ( ctxt, Script_map.make @@ -5263,13 +5389,12 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = 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 @@ -5279,7 +5404,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 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 -> @@ -5290,33 +5415,55 @@ let 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 : _ Script_list.t) -> List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -5325,7 +5472,7 @@ let 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 @@ -5341,12 +5488,15 @@ let rec fold_lazy_storage : 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 extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v = @@ -5362,10 +5512,15 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v 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) @@ -5374,7 +5529,7 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v 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 ?type_logger = parse_data @@ -5390,43 +5545,50 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ~elab_conf tc_context ctxt script_instr stack_ty -> - parse_instr ~elab_conf ~stack_depth:0 tc_context ctxt script_instr stack_ty + parse_instr_aux + ~elab_conf + ~stack_depth:0 + tc_context + ctxt + script_instr + stack_ty -let unparse_data = unparse_data ~stack_depth:0 +let unparse_data = Data_unparser_Michelson.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) -> + Data_unparser_Michelson.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 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 _) -> @@ -5442,31 +5604,31 @@ let 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 @@ -5486,5 +5648,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_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index dd9af56c6fdc3..2bb8aef22e381 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -110,6 +110,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 @@ -126,6 +127,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_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 6315ff10db35c..3eb7f9641996c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -148,7 +148,7 @@ let rec unparse_ty_and_entrypoints_uncarbonated : in Prim (loc, name, args, annot) -and unparse_comparable_ty_uncarbonated : +and[@coq_mutual_as_notation] 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 @@ -396,7 +396,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let rec unparse_comparable_data_rec : +let[@coq_struct "ty_value"] rec unparse_comparable_data_rec : type a loc. loc:loc -> context -> @@ -405,42 +405,46 @@ let rec unparse_comparable_data_rec : a -> (loc Script.michelson_node * context) tzresult Lwt.t = fun ~loc ctxt mode ty a -> - (* No need for stack_depth here. Unlike [unparse_data], + (* No need for stack_depth here. Unlike [unparse_data_aux], [unparse_comparable_data] doesn't call [unparse_code]. 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 : 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_rec ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data_rec ~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_rec ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data_rec ~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_rec ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v | Never_t, _ -> . @@ -460,14 +464,14 @@ module type MICHELSON_PARSER = sig (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty tzresult - val parse_packable_ty : + val parse_packable_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult - val parse_data : + val parse_data_aux : elab_conf:Script_ir_translator_config.elab_config -> stack_depth:int -> context -> @@ -477,10 +481,64 @@ module type MICHELSON_PARSER = sig ('a * t) tzresult Lwt.t end -module Data_unparser (P : MICHELSON_PARSER) = struct +module type DATA_UNPARSER = sig + (** [unparse_data_aux ctxt ~stack_depth unparsing_mode ty data] returns the + Micheline representation of [data] of type [ty], consuming an appropriate + amount of gas from [ctxt]. *) + val unparse_data_aux : + context -> + stack_depth:int -> + unparsing_mode -> + ('a, 'ac) ty -> + 'a -> + (Script.expr * context) tzresult Lwt.t + + (** [unparse_items_aux ctxt ~stack_depth unparsing_mode kty vty assoc] returns the + Micheline representation of [assoc] (being an association list) with keys + of type [kty] and values of type [vty]. Gas is being consumed from + [ctxt]. *) + val unparse_items_aux : + context -> + stack_depth:int -> + unparsing_mode -> + 'k comparable_ty -> + ('v, 'vc) ty -> + ('k * 'v) list -> + (Script.expr list * context) tzresult Lwt.t + + (** [unparse_code_aux ctxt ~stack_depth unparsing_mode code] returns [code] + with [I_PUSH] instructions parsed and unparsed back to make sure that + only forgeable values are being pushed. The gas is being consumed from + [ctxt]. *) + val unparse_code_aux : + context -> + stack_depth:int -> + unparsing_mode -> + Script.node -> + (Script.expr * context, error trace) result Lwt.t + + module Internal_for_benchmarking : sig + val unparse_data : + context -> + stack_depth:int -> + unparsing_mode -> + ('a, 'ac) ty -> + 'a -> + (Script.node * context) tzresult Lwt.t + + val unparse_code : + context -> + stack_depth:int -> + unparsing_mode -> + Script.node -> + (Script.node * context) tzresult Lwt.t + end +end + +module Data_unparser (P : MICHELSON_PARSER) : DATA_UNPARSER = struct open Script_tc_errors - let rec unparse_data_rec : + let[@coq_struct "ctxt"] rec unparse_data_rec : type a ac. context -> stack_depth:int -> @@ -496,43 +554,51 @@ module Data_unparser (P : MICHELSON_PARSER) = struct else unparse_data_rec 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 : _ Script_list.t) -> List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -540,7 +606,8 @@ module Data_unparser (P : MICHELSON_PARSER) = struct ([], 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 *) P.opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in @@ -551,7 +618,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct mode t (addr, (contents, (amount :> Script_int.n Script_int.num))) - | Set_t (t, _), set -> + | Set_t (t, _), (set : _ set) -> List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data_rec ~loc ctxt mode t item @@ -559,62 +626,88 @@ module Data_unparser (P : MICHELSON_PARSER) = struct ([], 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_rec 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_rec 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_rec 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_rec ctxt ~stack_depth:(stack_depth + 1) mode original_code - | Lambda_t _, LamRec (_, original_code) -> - unparse_code_rec ctxt ~stack_depth:(stack_depth + 1) mode original_code - >|=? fun (body, ctxt) -> - (Micheline.Prim (loc, D_Lambda_rec, [body], []), ctxt) + | 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_rec + 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_rec + ctxt + ~stack_depth:(stack_depth + 1) + mode + kt + vt + items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)) + | Lambda_t _, (x : _ lambda) -> ( + match x with + | Lam (_, original_code) -> + unparse_code_rec + ctxt + ~stack_depth:(stack_depth + 1) + mode + original_code + | LamRec (_, original_code) -> + unparse_code_rec + ctxt + ~stack_depth:(stack_depth + 1) + mode + original_code + >|=? fun (body, ctxt) -> + (Micheline.Prim (loc, D_Lambda_rec, [body], []), ctxt)) | Never_t, _ -> . - | Sapling_transaction_t _, s -> + | Sapling_transaction_t _, (s : Sapling.transaction) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> @@ -622,7 +715,8 @@ module Data_unparser (P : MICHELSON_PARSER) = struct 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 -> @@ -632,7 +726,8 @@ module Data_unparser (P : MICHELSON_PARSER) = struct 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 @@ -654,14 +749,14 @@ module Data_unparser (P : MICHELSON_PARSER) = struct 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 @@ -670,7 +765,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct ~plaintext_size:(Script_timelock.get_plaintext_size s)) Script_timelock.chest_encoding - and unparse_items_rec : + and[@coq_mutual_as_notation] unparse_items_rec : type k v vc. context -> stack_depth:int -> @@ -690,7 +785,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct ([], ctxt) items - and unparse_code_rec ctxt ~stack_depth mode code = + and[@coq_struct "ctxt"] unparse_code_rec ctxt ~stack_depth mode code = let elab_conf = Script_ir_translator_config.make ~legacy:true () in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = @@ -700,12 +795,12 @@ module Data_unparser (P : MICHELSON_PARSER) = struct in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - P.parse_packable_ty + P.parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:elab_conf.legacy ty - >>?= fun (Ex_ty t, ctxt) -> + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -713,7 +808,7 @@ module Data_unparser (P : MICHELSON_PARSER) = struct from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - P.parse_data + P.parse_data_aux ~elab_conf ctxt ~stack_depth:(stack_depth + 1) @@ -721,7 +816,12 @@ module Data_unparser (P : MICHELSON_PARSER) = struct t data >>=? fun (data, ctxt) -> - unparse_data_rec ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_rec + 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) -> @@ -744,16 +844,16 @@ module Data_unparser (P : MICHELSON_PARSER) = struct return (Prim (loc, prim, List.rev items, annot), ctxt) | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) - let unparse_data ctxt ~stack_depth mode ty v = + let unparse_data_aux ctxt ~stack_depth mode ty v = unparse_data_rec ctxt ~stack_depth mode ty v >>=? fun (unparsed_data, ctxt) -> Lwt.return (account_for_future_serialization_cost unparsed_data ctxt) - let unparse_code ctxt ~stack_depth mode v = + let unparse_code_aux ctxt ~stack_depth mode v = unparse_code_rec ctxt ~stack_depth mode v >>=? fun (unparsed_data, ctxt) -> Lwt.return (account_for_future_serialization_cost unparsed_data ctxt) - let unparse_items ctxt ~stack_depth mode ty vty vs = + let unparse_items_aux ctxt ~stack_depth mode ty vty vs = unparse_items_rec ctxt ~stack_depth mode ty vty vs >>=? fun (unparsed_datas, ctxt) -> List.fold_left_e diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 908fd7cdeaf0b..47c91bbd0b517 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -153,14 +153,14 @@ module type MICHELSON_PARSER = sig (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty tzresult - val parse_packable_ty : + val parse_packable_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult - val parse_data : + val parse_data_aux : elab_conf:Script_ir_translator_config.elab_config -> stack_depth:int -> context -> @@ -170,11 +170,11 @@ module type MICHELSON_PARSER = sig ('a * t) tzresult Lwt.t end -module Data_unparser : functor (P : MICHELSON_PARSER) -> sig - (** [unparse_data ctxt ~stack_depth unparsing_mode ty data] returns the +module type DATA_UNPARSER = sig + (** [unparse_data_aux ctxt ~stack_depth unparsing_mode ty data] returns the Micheline representation of [data] of type [ty], consuming an appropriate amount of gas from [ctxt]. *) - val unparse_data : + val unparse_data_aux : context -> stack_depth:int -> unparsing_mode -> @@ -182,11 +182,11 @@ module Data_unparser : functor (P : MICHELSON_PARSER) -> sig 'a -> (Script.expr * context) tzresult Lwt.t - (** [unparse_items ctxt ~stack_depth unparsing_mode kty vty assoc] returns the + (** [unparse_items_aux ctxt ~stack_depth unparsing_mode kty vty assoc] returns the Micheline representation of [assoc] (being an association list) with keys of type [kty] and values of type [vty]. Gas is being consumed from [ctxt]. *) - val unparse_items : + val unparse_items_aux : context -> stack_depth:int -> unparsing_mode -> @@ -195,11 +195,11 @@ module Data_unparser : functor (P : MICHELSON_PARSER) -> sig ('k * 'v) list -> (Script.expr list * context) tzresult Lwt.t - (** [unparse_code ctxt ~stack_depth unparsing_mode code] returns [code] + (** [unparse_code_aux ctxt ~stack_depth unparsing_mode code] returns [code] with [I_PUSH] instructions parsed and unparsed back to make sure that only forgeable values are being pushed. The gas is being consumed from [ctxt]. *) - val unparse_code : + val unparse_code_aux : context -> stack_depth:int -> unparsing_mode -> @@ -226,3 +226,5 @@ module Data_unparser : functor (P : MICHELSON_PARSER) -> sig (Script.node * context) tzresult Lwt.t end end + +module Data_unparser (P : MICHELSON_PARSER) : DATA_UNPARSER diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml index 5e7dcf3b44da3..70f2c38f91f8d 100644 --- a/src/proto_alpha/lib_protocol/script_map.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/script_repr.ml b/src/proto_alpha/lib_protocol/script_repr.ml index 7c5aca4c7893f..070a3f26b3dd9 100644 --- a/src/proto_alpha/lib_protocol/script_repr.ml +++ b/src/proto_alpha/lib_protocol/script_repr.ml @@ -122,7 +122,7 @@ module Micheline_size = struct let of_annots acc annots = List.fold_left (fun acc s -> add_string acc s) acc annots - let rec of_nodes acc nodes more_nodes = + let[@coq_struct "nodes"] rec of_nodes acc nodes more_nodes = let open Micheline in match nodes with | [] -> ( @@ -253,11 +253,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 @@ -266,8 +268,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 @@ -332,7 +334,8 @@ let rec micheline_fold_aux node f acc k = | Micheline.Seq (_, subterms) -> micheline_fold_nodes subterms f (f acc node) k -and micheline_fold_nodes subterms f acc k = +and[@coq_mutual_as_notation] [@coq_struct "subterms"] micheline_fold_nodes + subterms f acc k = match subterms with | [] -> k acc | node :: nodes -> diff --git a/src/proto_alpha/lib_protocol/script_set.ml b/src/proto_alpha/lib_protocol/script_set.ml index c18824cdb973b..01ad398d0e5e9 100644 --- a/src/proto_alpha/lib_protocol/script_set.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/script_string.ml b/src/proto_alpha/lib_protocol/script_string.ml index b3108eb31ef23..ea0c6bca872cc 100644 --- a/src/proto_alpha/lib_protocol/script_string.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index 64be6905ed237..9e5f9e733e368 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -218,6 +218,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_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 40c3afe6ca64d..00f9cc86750f2 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -243,7 +243,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 -> @@ -298,7 +298,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)) @@ -401,6 +401,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} @@ -466,7 +469,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = Script.location * ('b, 'a * ('c * 's), 'r, 'f) kinstr -> ('a, 'b * ('c * 's), 'r, 'f) kinstr | IConst : - Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 's, 'r, 'f) kinstr + Script.location * ('t, _) ty * 't * ('t, 'a * 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr (* Pairs @@ -1139,6 +1142,7 @@ and ('arg, 'ret) lambda = ('arg, ('arg, 'ret) lambda * end_of_stack, 'ret, end_of_stack) kdescr * Script.node -> ('arg, 'ret) lambda +[@@coq_force_gadt] and 'arg typed_contract = | Typed_implicit : public_key_hash -> unit typed_contract @@ -1164,6 +1168,7 @@ and 'arg typed_contract = zk_rollup : Zk_rollup.t; } -> ('a ticket, bytes) pair typed_contract +[@@coq_force_gadt] and (_, _, _, _) continuation = | KNil : ('r, 'f, 'r, 'f) continuation @@ -1228,6 +1233,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 -> @@ -1349,6 +1355,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 @@ -1366,6 +1373,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; @@ -1415,6 +1423,7 @@ and ('value, 'before, 'after) comb_set_gadt_witness = | Comb_set_plus_two : ('value, 'before, 'after) comb_set_gadt_witness -> ('value, 'a * 'before, 'a * 'after) comb_set_gadt_witness +[@@coq_force_gadt] and (_, _, _, _) dup_n_gadt_witness = | Dup_n_zero : ('a, _, _, 'a) dup_n_gadt_witness @@ -1429,6 +1438,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind internal_operation_contents = | Transaction_to_implicit : { @@ -1505,7 +1515,7 @@ and operation = { type ex_ty = Ex_ty : ('a, _) ty -> ex_ty -type ('arg, 'storage) script = +type (_, 'storage) script = | Script : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; @@ -1762,7 +1772,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 @@ -2111,7 +2122,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 = @@ -2142,7 +2153,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 -> @@ -2154,14 +2166,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; @@ -2178,79 +2192,106 @@ 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 : _ Script_list.t) -> 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) + (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 module Typed_contract = struct diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 01da712c40635..c7b7f1af7eee6 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -195,7 +195,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 -> @@ -275,6 +275,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 @@ -446,7 +448,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = Script.location * ('b, 'a * ('c * 's), 'r, 'f) kinstr -> ('a, 'b * ('c * 's), 'r, 'f) kinstr | IConst : - Script.location * ('ty, _) ty * 'ty * ('ty, 'a * 's, 'r, 'f) kinstr + Script.location * ('t, _) ty * 't * ('t, 'a * 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr (* Pairs @@ -1159,6 +1161,7 @@ and ('arg, 'ret) lambda = ('arg, ('arg, 'ret) lambda * end_of_stack, 'ret, end_of_stack) kdescr * Script.node -> ('arg, 'ret) lambda +[@@coq_force_gadt] and 'arg typed_contract = | Typed_implicit : public_key_hash -> unit typed_contract @@ -1184,6 +1187,7 @@ and 'arg typed_contract = zk_rollup : Zk_rollup.t; } -> ('a ticket, bytes) pair typed_contract +[@@coq_force_gadt] (* @@ -1464,6 +1468,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 @@ -1481,6 +1486,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; @@ -1554,6 +1560,7 @@ and ('value, 'before, 'after) comb_set_gadt_witness = | Comb_set_plus_two : ('value, 'before, 'after) comb_set_gadt_witness -> ('value, 'a * 'before, 'a * 'after) comb_set_gadt_witness +[@@coq_force_gadt] (* @@ -1578,6 +1585,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind internal_operation_contents = | Transaction_to_implicit : { @@ -1657,7 +1665,7 @@ and operation = { lazy_storage_diff : Lazy_storage.diffs option; } -type ('arg, 'storage) script = +type (_, 'storage) script = | Script : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; @@ -1680,7 +1688,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_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 6a6cae55907b0..a9fe543b7fa2f 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -248,7 +248,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 -> @@ -258,64 +258,82 @@ 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 : _ Script_list.t) -> + 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 !!Bls.Primitive.G1.size_in_memory - | Bls12_381_g2_t -> ret_succ_adding accu !!Bls.Primitive.G2.size_in_memory - | Bls12_381_fr_t -> ret_succ_adding accu !!Bls.Primitive.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 !!Bls.Primitive.G1.size_in_memory + | Bls12_381_g2_t, _ -> + ret_succ_adding accu !!Bls.Primitive.G2.size_in_memory + | Bls12_381_fr_t, _ -> + ret_succ_adding accu !!Bls.Primitive.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} -and big_map_size : +and[@coq_mutual_as_notation] big_map_size_aux : type a b bc. count_lambda_nodes:bool -> nodes_and_size -> @@ -335,12 +353,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 @@ -352,7 +374,7 @@ and big_map_size : (ty_size key_type ++ ty_size value_type ++ diff_size) (h4w +! id_size) -and lambda_size : +and[@coq_struct "lam"] lambda_size_aux : type i o. count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size = @@ -365,13 +387,13 @@ and lambda_size : (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 in match lam with | Lam (kdescr, node) -> count_lambda_body kdescr node | LamRec (kdescr, node) -> count_lambda_body kdescr node -and kdescr_size : +and[@coq_mutual_as_notation] kdescr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -381,9 +403,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 -> @@ -416,7 +438,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 @@ -549,7 +571,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) -> @@ -685,11 +707,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_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml index 2149807533e3a..3b004972afecc 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.ml +++ b/src/proto_alpha/lib_protocol/seed_repr.ml @@ -111,7 +111,7 @@ let seed_encoding = let open Data_encoding in conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding -let update_seed (B state) nonce = +let update_seed_aux (B state) nonce = B (State_hash.hash_bytes [State_hash.to_bytes state; nonce]) let initialize_new (B state) append = @@ -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 @@ -212,16 +212,16 @@ let initial_nonce_0 = zero_bytes let initial_nonce_hash_0 = hash initial_nonce_0 -let deterministic_seed seed = update_seed seed zero_bytes +let deterministic_seed seed = update_seed_aux seed zero_bytes let initial_seeds ?initial_seed n = - let 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 let first_seed = match initial_seed with - | Some initial_seed -> update_seed (B initial_seed) initial_nonce_0 + | Some initial_seed -> update_seed_aux (B initial_seed) initial_nonce_0 | None -> B (State_hash.hash_bytes []) in loop [] first_seed n @@ -233,10 +233,10 @@ let nonce_challenge = Bytes.of_string "Tezos_generating_vdf_challenge" let generate_vdf_setup ~seed_discriminant ~seed_challenge = let size = Vdf.discriminant_size_bytes in let seed = - update_seed seed_discriminant nonce_discriminant |> seed_to_bytes + update_seed_aux seed_discriminant nonce_discriminant |> seed_to_bytes in let discriminant = Vdf.generate_discriminant ~seed size in - let input = update_seed seed_challenge nonce_challenge |> seed_to_bytes in + let input = update_seed_aux seed_challenge nonce_challenge |> seed_to_bytes in let challenge = Vdf.generate_challenge discriminant input in (discriminant, challenge) @@ -250,7 +250,7 @@ let verify (discriminant, challenge) vdf_difficulty solution = let vdf_to_seed seed_challenge solution = let result, _ = solution in - update_seed seed_challenge (Vdf.result_to_bytes result) + update_seed_aux seed_challenge (Vdf.result_to_bytes result) type seed_status = RANDAO_seed | VDF_seed diff --git a/src/proto_alpha/lib_protocol/seed_repr.mli b/src/proto_alpha/lib_protocol/seed_repr.mli index 343e8405ba84a..bea8f74c8453a 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.mli +++ b/src/proto_alpha/lib_protocol/seed_repr.mli @@ -91,7 +91,7 @@ val take_int64 : sequence -> int64 -> int64 * sequence type nonce (** Add entropy to the seed generator *) -val update_seed : seed -> nonce -> seed +val update_seed_aux : seed -> nonce -> seed (** Use a byte sequence as a nonce *) val make_nonce : bytes -> nonce tzresult diff --git a/src/proto_alpha/lib_protocol/seed_storage.ml b/src/proto_alpha/lib_protocol/seed_storage.ml index 90021630c1138..5c3cfc92a7990 100644 --- a/src/proto_alpha/lib_protocol/seed_storage.ml +++ b/src/proto_alpha/lib_protocol/seed_storage.ml @@ -137,7 +137,8 @@ let compute_randao ctxt = (* Generate preserved seed by updating previous preserved seed with current revealed nonces. *) let combine (c, random_seed) level = Storage.Seed.Nonce.get c level >>=? function - | Revealed nonce -> return (c, Seed_repr.update_seed random_seed nonce) + | Revealed nonce -> + return (c, Seed_repr.update_seed_aux random_seed nonce) | Unrevealed _ -> return (c, random_seed) in let seed = Seed_repr.deterministic_seed prev_seed in diff --git a/src/proto_alpha/lib_protocol/services_registration.ml b/src/proto_alpha/lib_protocol/services_registration.ml index de94c5dbdf695..4fa5d81a2d9c3 100644 --- a/src/proto_alpha/lib_protocol/services_registration.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/services_registration.mli b/src/proto_alpha/lib_protocol/services_registration.mli index c6bc2ed72c92a..da7faca5500a2 100644 --- a/src/proto_alpha/lib_protocol/services_registration.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/skip_list_repr.ml b/src/proto_alpha/lib_protocol/skip_list_repr.ml index 7821e2034257f..8cd7e5228ed24 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/skip_list_repr.ml @@ -23,6 +23,17 @@ (* *) (*****************************************************************************) +type 'cell search_cell_result = + | Found of 'cell + | Nearest of {lower : 'cell; upper : 'cell option} + | No_exact_or_lower_ptr + | Deref_returned_none + +type 'cell search_result = { + rev_path : 'cell list; + last_cell : 'cell search_cell_result; +} + module type S = sig type ('content, 'ptr) cell @@ -45,7 +56,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 @@ -81,19 +92,11 @@ module type S = sig 'ptr list -> bool - type ('ptr, 'content) search_cell_result = - | Found of ('ptr, 'content) cell - | Nearest of { - lower : ('ptr, 'content) cell; - upper : ('ptr, 'content) cell option; - } - | No_exact_or_lower_ptr - | Deref_returned_none - - type ('ptr, 'content) search_result = { - rev_path : ('ptr, 'content) cell list; - last_cell : ('ptr, 'content) search_cell_result; - } + type nonrec ('ptr, 'content) search_cell_result = + ('content, 'ptr) cell search_cell_result + + type nonrec ('ptr, 'content) search_result = + ('ptr, 'content) cell search_result val pp_search_result : pp_cell:(Format.formatter -> ('ptr, 'content) cell -> unit) -> @@ -108,9 +111,11 @@ module type S = sig ('content, 'ptr) search_result 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 @@ -223,7 +228,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 = @@ -247,7 +252,7 @@ end) : S = struct (* returns the array of [basis^i] forall [i < len (back_pointers cell)] *) let list_powers cell = - let rec aux n prev p = + let[@coq_struct "n_value"] rec aux n prev p = if Compare.Int.(n <= 0) then List.rev p else aux (n - 1) (basis * prev) (prev :: p) in @@ -267,7 +272,7 @@ end) : S = struct let best_skip cell target_index powers = let open FallbackArray in let pointed_cell_index i = cell.index - (cell.index mod get powers i) - 1 in - let rec binary_search start_idx end_idx = + let[@coq_struct "start_idx"] rec binary_search start_idx end_idx = if Compare.Int.(start_idx >= end_idx) then Some start_idx else let mid_idx = start_idx + ((end_idx - start_idx) / 2) in @@ -295,7 +300,7 @@ end) : S = struct let open Option_syntax in let* cell = deref cell_ptr in let powers = list_powers cell in - let rec aux path ptr = + let[@coq_struct "ptr"] rec aux path ptr = let path = ptr :: path in let* cell = deref ptr in let index = cell.index in @@ -322,7 +327,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 get l idx with @@ -339,7 +344,7 @@ end) : S = struct let target_index = index target and cell_index = index cell and powers = list_powers 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) @@ -358,24 +363,16 @@ end) : S = struct | first_cell_ptr :: path -> equal_ptr first_cell_ptr cell_ptr && valid_path cell_index cell_ptr path - type ('ptr, 'content) search_cell_result = - | Found of ('ptr, 'content) cell - | Nearest of { - lower : ('ptr, 'content) cell; - upper : ('ptr, 'content) cell option; - } - | No_exact_or_lower_ptr - | Deref_returned_none - - type ('ptr, 'content) search_result = { - rev_path : ('ptr, 'content) cell list; - last_cell : ('ptr, 'content) search_cell_result; - } + type nonrec ('ptr, 'content) search_cell_result = + ('content, 'ptr) cell search_cell_result + + type nonrec ('ptr, 'content) search_result = + ('ptr, 'content) cell search_result let pp_rev_path ~pp_cell = Format.pp_print_list ~pp_sep:Format.pp_print_space pp_cell - let pp_search_cell_result ~pp_cell fmt = function + let pp_search_cell_result ~pp_cell fmt : _ search_cell_result -> _ = function | Found ptr -> Format.fprintf fmt "Found(%a)" pp_cell ptr | Nearest {lower; upper} -> Format.fprintf @@ -388,7 +385,7 @@ end) : S = struct | No_exact_or_lower_ptr -> Format.fprintf fmt "No_exact_or_lower_ptr" | Deref_returned_none -> Format.fprintf fmt "Deref_returned_none" - let pp_search_result ~pp_cell fmt {rev_path; last_cell} = + let pp_search_result ~pp_cell fmt ({rev_path; last_cell} : _ search_result) = Format.fprintf fmt "{rev_path = %a; last_point = %a}" @@ -398,7 +395,7 @@ end) : S = struct last_cell let search (type ptr) ~(deref : ptr -> ('content, ptr) cell option) ~compare - ~cell = + ~cell : _ search_result = let ( = ), ( < ), ( > ) = Compare.Int.(( = ), ( < ), ( > )) in (* Given a cell, to compute the minimal path, we need to find the good back-pointer. This is done linearly with respect to the @@ -412,7 +409,7 @@ end) : S = struct necessary. But since this piece of code won't be used in a carbonated function, we prefer to keep a simple implementation for the moment. *) - let rec aux rev_path cell ix = + let[@coq_struct "ix"] rec aux rev_path cell ix : _ search_result = (* Below, we call the [target] the cell for which [compare target = 0]. *) (* Invariant: diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.mli b/src/proto_alpha/lib_protocol/skip_list_repr.mli index 41270ed47435c..bf0c53847b4db 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.mli +++ b/src/proto_alpha/lib_protocol/skip_list_repr.mli @@ -25,6 +25,17 @@ (** This module provides an implementation of the skip list data structure. *) +type 'cell search_cell_result = + | Found of 'cell + | Nearest of {lower : 'cell; upper : 'cell option} + | No_exact_or_lower_ptr + | Deref_returned_none + +type 'cell search_result = { + rev_path : 'cell list; + last_cell : 'cell search_cell_result; +} + (** A skip list represents a sequence of values. There are three main differences between these [skip list]s and OCaml standard [list]s: @@ -71,7 +82,7 @@ module type S = sig ('content, 'ptr) cell Data_encoding.t (** [index cell] returns the position of [cell] in the sequence. *) - val index : (_, _) cell -> int + val index : ('content, 'ptr) cell -> int (** [content cell] is the content carried by the [cell]. *) val content : ('content, 'ptr) cell -> 'content @@ -127,19 +138,11 @@ module type S = sig 'ptr list -> bool - type ('ptr, 'content) search_cell_result = - | Found of ('ptr, 'content) cell - | Nearest of { - lower : ('ptr, 'content) cell; - upper : ('ptr, 'content) cell option; - } - | No_exact_or_lower_ptr - | Deref_returned_none + type nonrec ('ptr, 'content) search_cell_result = + ('content, 'ptr) cell search_cell_result - type ('ptr, 'content) search_result = { - rev_path : ('ptr, 'content) cell list; - last_cell : ('ptr, 'content) search_cell_result; - } + type nonrec ('ptr, 'content) search_result = + ('ptr, 'content) cell search_result val pp_search_result : pp_cell:(Format.formatter -> ('ptr, 'content) cell -> unit) -> @@ -198,6 +201,8 @@ module type S = sig ('content, 'ptr) search_result 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_alpha/lib_protocol/slot_repr.ml b/src/proto_alpha/lib_protocol/slot_repr.ml index 9e72811663ce3..6415e481ecd4e 100644 --- a/src/proto_alpha/lib_protocol/slot_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index ab1eff9872cde..1161082591352 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -99,7 +99,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) @@ -107,7 +107,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) @@ -124,14 +124,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) @@ -170,7 +170,7 @@ end module Contract = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["contracts"] end) @@ -431,7 +431,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)) @@ -449,7 +449,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) @@ -524,7 +524,11 @@ module Big_map = struct let encoding = Script_repr.expr_encoding end) - module Contents = struct + module Contents : + Indexed_carbonated_data_storage + with type key = Script_expr_hash.t + and type value = Script_repr.expr + and type t := key = struct module I = Storage_functors.Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) @@ -585,7 +589,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) @@ -942,7 +946,7 @@ end module Delegates = Make_data_set_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["delegates"] end)) @@ -950,7 +954,7 @@ module Delegates = module Consensus_keys = Make_data_set_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["consensus_keys"] end)) @@ -976,7 +980,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)) @@ -1088,7 +1092,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)) @@ -1098,7 +1102,7 @@ module Stake = struct module Active_delegates_with_minimal_stake = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct (* This name is for historical reasons, when the stake was expressed in rolls (that is, pre-Ithaca). *) @@ -1134,7 +1138,7 @@ module Stake = struct 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) @@ -1147,7 +1151,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) @@ -1262,8 +1266,11 @@ end (** Seed *) -module Seed_status = - Make_single_data_storage (Registered) (Raw_context) +module Seed_status : + Single_data_storage + with type t := Raw_context.t + and type value = Seed_repr.seed_status = + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["seed_status"] end) @@ -1318,7 +1325,7 @@ module Seed = struct end module VDF_setup = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["vdf_challenge"] end) @@ -1353,7 +1360,7 @@ end module Commitments = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["commitments"] end)) @@ -1371,7 +1378,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)) @@ -1407,7 +1414,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) @@ -1418,7 +1425,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) @@ -1453,7 +1460,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"] @@ -1461,7 +1468,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) @@ -1478,7 +1485,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) @@ -1501,14 +1508,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)) @@ -1581,7 +1593,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) @@ -1594,58 +1606,61 @@ module Sc_rollup = struct end)) (Make_index (Sc_rollup_repr.Index)) - module Make_versioned - (Versioned_value : Sc_rollup_data_version_sig.S) (Data_storage : sig - type context + module type DATA_STORAGE = sig + type context - type key + type key - type value = Versioned_value.versioned + type value - val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t + val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t - val find : - context -> key -> (Raw_context.t * value option) tzresult Lwt.t + val find : context -> key -> (Raw_context.t * value option) tzresult Lwt.t - val update : - context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + val update : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t - val init : - context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t + val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t - val add : - context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t + val add : + context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t - val add_or_remove : - context -> - key -> - value option -> - (Raw_context.t * int * bool) tzresult Lwt.t - end) = - struct - include Data_storage + val add_or_remove : + context -> + key -> + value option -> + (Raw_context.t * int * bool) tzresult Lwt.t + end + module Make_versioned + (Versioned_value : Sc_rollup_data_version_sig.S) + (Data_storage : DATA_STORAGE with type value = Versioned_value.versioned) = + struct type value = Versioned_value.t let get ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = get ctxt key in + let* ctxt, versioned = Data_storage.get ctxt key in return (ctxt, Versioned_value.of_versioned versioned) let find ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = find ctxt key in + let* ctxt, versioned = Data_storage.find ctxt key in return (ctxt, Option.map Versioned_value.of_versioned versioned) let update ctxt key value = - update ctxt key (Versioned_value.to_versioned value) + Data_storage.update ctxt key (Versioned_value.to_versioned value) - let init ctxt key value = init ctxt key (Versioned_value.to_versioned value) + let init ctxt key value = + Data_storage.init ctxt key (Versioned_value.to_versioned value) - let add ctxt key value = add ctxt key (Versioned_value.to_versioned value) + let add ctxt key value = + Data_storage.add ctxt key (Versioned_value.to_versioned value) let add_or_remove ctxt key value = - add_or_remove ctxt key (Option.map Versioned_value.to_versioned value) + Data_storage.add_or_remove + ctxt + key + (Option.map Versioned_value.to_versioned value) end module PVM_kind = @@ -1736,7 +1751,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_commitment_repr.Hash.encoding end) - module Stakers = + module Stakers : + 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 @@ -1777,12 +1796,35 @@ module Sc_rollup = struct let encoding = Sc_rollup_commitment_repr.versioned_encoding end) - module Commitments = struct - include Commitments_versioned - include Make_versioned (Sc_rollup_commitment_repr) (Commitments_versioned) + module Commitments : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = Sc_rollup_commitment_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = struct + type t = Commitments_versioned.t + + type context = Commitments_versioned.context + + type key = Commitments_versioned.key + + let mem = Commitments_versioned.mem + + let remove_existing = Commitments_versioned.remove_existing + + let remove = Commitments_versioned.remove + + let keys_unaccounted = Commitments_versioned.keys_unaccounted + + module M = + Make_versioned (Sc_rollup_commitment_repr) (Commitments_versioned) + include M 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 @@ -1804,7 +1846,11 @@ module Sc_rollup = struct (Make_index (Raw_level_repr.Index)) (Raw_level_repr) - 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 @@ -1830,12 +1876,34 @@ module Sc_rollup = struct let encoding = Sc_rollup_game_repr.versioned_encoding end) - module Game = struct - include Game_versioned - include Make_versioned (Sc_rollup_game_repr) (Game_versioned) + module Game : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.t + and type value = Sc_rollup_game_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = struct + type t = Game_versioned.t + + type context = Game_versioned.context + + type key = Game_versioned.key + + let mem = Game_versioned.mem + + let remove_existing = Game_versioned.remove_existing + + let remove = Game_versioned.remove + + let keys_unaccounted = Game_versioned.keys_unaccounted + + module M = Make_versioned (Sc_rollup_game_repr) (Game_versioned) + include M end - module Game_timeout = + module Game_timeout : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.t + and type value = Sc_rollup_game_repr.timeout + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1848,7 +1916,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_game_repr.timeout_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 @@ -1926,7 +1998,7 @@ end module Dal = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["dal"] end) @@ -1981,7 +2053,7 @@ end module Zk_rollup = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["zk_rollup"] end)) diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index 19930309cd542..48af01ef32802 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -515,7 +515,9 @@ end (** Seed *) module Seed_status : - Simple_single_data_storage with type value = Seed_repr.seed_status + Single_data_storage + with type t := Raw_context.t + and type value = Seed_repr.seed_status module Seed : sig (** Storage from this submodule must only be accessed through the @@ -765,7 +767,7 @@ module Sc_rollup : sig and type t := Raw_context.t module Stakers : - Non_iterable_indexed_carbonated_data_storage + 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 diff --git a/src/proto_alpha/lib_protocol/storage_description.ml b/src/proto_alpha/lib_protocol/storage_description.ml index 9b3eb082492f8..2ea69d3132d87 100644 --- a/src/proto_alpha/lib_protocol/storage_description.ml +++ b/src/proto_alpha/lib_protocol/storage_description.ml @@ -56,7 +56,8 @@ and 'key description = } -> 'key description -let rec pp : type a. Format.formatter -> a t -> unit = +let[@coq_struct "function_parameter"] rec pp : + type a. Format.formatter -> a t -> unit = fun ppf {dir; _} -> match dir with | Empty -> Format.fprintf ppf "Empty" @@ -71,7 +72,8 @@ let rec pp : type a. Format.formatter -> a t -> unit = let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in pp_item ppf (name, subdir) -and pp_item : type a. Format.formatter -> string * a t -> unit = +and[@coq_mutual_as_notation] pp_item : + type a. Format.formatter -> string * a t -> unit = fun ppf (name, desc) -> Format.fprintf ppf "@[%s@ %a@]" name pp desc let pp_rev_path ppf path = @@ -122,27 +124,33 @@ 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)) -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 -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 @@ -159,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 @@ -177,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 @@ -198,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 -> @@ -210,7 +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)) + | Some RPC_arg.Eq -> ((subdir [@coq_cast]) : b t))) let register_value : type a b. @@ -241,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; @@ -294,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)} @@ -333,48 +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 diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index bde65c9d02730..155419b02e641 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -118,7 +118,6 @@ struct let config t = C.config t module Tree = C.Tree - module Proof = C.Proof let verify_tree_proof = C.verify_tree_proof @@ -201,6 +200,7 @@ struct ~get:find (register_named_subcontext description N.name) V.encoding + [@@coq_axiom_with_reason "stack overflow in Coq"] end module type INDEX = sig @@ -255,7 +255,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 = @@ -273,6 +275,7 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : C.description I.args) Data_encoding.bool + [@@coq_axiom_with_reason "stack overflow in Coq"] end module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) : @@ -326,7 +329,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 @@ -356,6 +359,7 @@ struct C.description I.args) V.encoding + [@@coq_axiom_with_reason "stack overflow in Coq"] end (* Internal-use-only version of {!Make_indexed_carbonated_data_storage} to @@ -504,7 +508,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 -> (* This also accounts for gas for loading the element. *) get_unprojected s key >|=? fun (s, value) -> @@ -532,9 +536,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 = @@ -553,18 +557,19 @@ module Make_indexed_carbonated_data_storage_INTERNAL C.description I.args) V.encoding + [@@coq_axiom_with_reason "stack overflow in Coq"] end -module Make_indexed_carbonated_data_storage : functor - (C : Raw_context.T) - (I : INDEX) - (V : VALUE) - -> +module Make_indexed_carbonated_data_storage + (C : Raw_context.T) + (I : INDEX) + (V : VALUE) : Indexed_carbonated_data_storage with type t = C.t and type key = I.t - and type value = V.t = - Make_indexed_carbonated_data_storage_INTERNAL + and type value = V.t = struct + include Make_indexed_carbonated_data_storage_INTERNAL (C) (I) (V) +end module Make_carbonated_data_set_storage (C : Raw_context.T) (I : INDEX) : Carbonated_data_set_storage with type t = C.t and type elt = I.t = struct @@ -653,7 +658,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 @@ -688,7 +693,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) @@ -814,8 +819,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 @@ -909,6 +912,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : mem c k >>= function true -> return_some true | false -> return_none) (register_named_subcontext description N.name) Data_encoding.bool + [@@coq_axiom_with_reason "stack overflow in Coq"] end module Make_map (R : REGISTER) (N : NAME) (V : VALUE) : @@ -1010,6 +1014,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : find c k) (register_named_subcontext description N.name) V.encoding + [@@coq_axiom_with_reason "stack overflow in Coq"] module Local = struct type context = Raw_context.Local_context.t @@ -1178,6 +1183,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : find c k >|=? fun (_, v) -> v) (register_named_subcontext description N.name) V.encoding + [@@coq_axiom_with_reason "stack overflow in Coq"] end end diff --git a/src/proto_alpha/lib_protocol/storage_sigs.ml b/src/proto_alpha/lib_protocol/storage_sigs.ml index 7654bc4f1d810..9f6e4547c65e8 100644 --- a/src/proto_alpha/lib_protocol/storage_sigs.ml +++ b/src/proto_alpha/lib_protocol/storage_sigs.ml @@ -76,6 +76,7 @@ module type Single_data_storage = sig the bucket does not exists *) val remove : context -> Raw_context.t Lwt.t end +[@@coq_precise_signature] (** Restricted version of {!Indexed_data_storage} w/o iterators. *) module type Non_iterable_indexed_data_storage = sig @@ -129,6 +130,7 @@ module type Non_iterable_indexed_data_storage = sig bucket does not exists. *) val remove : context -> key -> Raw_context.t Lwt.t end +[@@coq_precise_signature] (** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *) module type Non_iterable_indexed_carbonated_data_storage = sig @@ -214,6 +216,7 @@ module type Non_iterable_indexed_carbonated_data_storage = sig Not carbonated (i.e. gas is not consumed); use with care. *) val keys_unaccounted : context -> key list Lwt.t end +[@@coq_precise_signature] module type Indexed_carbonated_data_storage = sig include Non_iterable_indexed_carbonated_data_storage diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index e9dc7de381d96..ce1095be1fda1 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -849,7 +849,7 @@ let sc_rollup_origination ?force_reveal ?counter ?fee ?gas_limit ?storage_limit let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in let origination_proof = - Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof + Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof_val in let* to_sign_op = manager_operation diff --git a/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml b/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml index 8a8a0cfb024af..225c8862e1363 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/operation_generator.ml @@ -664,7 +664,7 @@ let generate_sc_rollup_originate = in let (module PVM) = Sc_rollup.wrapped_proof_module origination_proof in let origination_proof = - Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof + Data_encoding.Binary.to_string_exn PVM.proof_encoding PVM.proof_val in QCheck2.Gen.pure (Sc_rollup_originate {kind; boot_sector; origination_proof; parameters_ty}) diff --git a/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml index d562124bb1cca..6d9fa91799c37 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml @@ -111,7 +111,7 @@ let origination_proof ~boot_sector = function (module struct include Arith_pvm - let proof = proof + let proof_val = proof end)) | Sc_rollup.Kind.Wasm_2_0_0 -> let open Lwt_syntax in @@ -123,7 +123,7 @@ let origination_proof ~boot_sector = function (module struct include Wasm_pvm - let proof = proof + let proof_val = proof end)) let wrap_origination_proof ~kind ~boot_sector proof_string_opt : diff --git a/src/proto_alpha/lib_protocol/tez_repr.ml b/src/proto_alpha/lib_protocol/tez_repr.ml index 2c16dfa99dbe2..ded083a021887 100644 --- a/src/proto_alpha/lib_protocol/tez_repr.ml +++ b/src/proto_alpha/lib_protocol/tez_repr.ml @@ -97,7 +97,7 @@ let of_string s = let pp ppf (Tez_tag amount) = let mult_int = 1_000_000L in - let rec left ppf amount = + let[@coq_struct "amount"] rec left ppf amount = let d, r = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in if d > 0L then Format.fprintf ppf "%a%03Ld" left d r else Format.fprintf ppf "%Ld" r diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index 329d402c40313..5c26c35f5431d 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -60,7 +60,7 @@ module Ticket_token_map = struct let+ ctxt = Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) in (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 @@ -97,7 +97,7 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = let*? token_amounts, ctxt = List.fold_left_e accum_ticket_balances ([], ctxt) tickets in - Ticket_token_map.of_list ctxt token_amounts + Ticket_token_map.of_list_with_merge ctxt token_amounts let update_ticket_balances ctxt ~total_storage_diff token destinations = let open Lwt_result_syntax in @@ -156,7 +156,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets ctxt lazy_storage_diff in - Ticket_token_map.of_list ctxt diffs + Ticket_token_map.of_list_with_merge ctxt diffs else return (Ticket_token_map.empty, ctxt) (* TODO #2465 diff --git a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml index fc7f79181e183..1fdc9e9245dc1 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/ticket_hash_repr.ml b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml index 21c1869114041..274f6366f3219 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index d49fe0b3cc5d2..fea78399559f0 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -78,7 +78,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. *) @@ -121,7 +121,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 @@ -175,12 +175,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_typed_ir.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_typed_ir.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 @@ -205,14 +205,14 @@ 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_typed_ir.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_typed_ir.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> (* Iterate over big-map items. *) Big_map.list_key_values ctxt big_map_id >>=? fun (ctxt, exprs) -> List.fold_left_es (fun (acc, ctxt) (_key_hash, node) -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "a" "__Ex_ty_'a"]) ctxt has_tickets node @@ -243,15 +243,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_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 60c7f1fccf184..f615e72c7fd51 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -164,7 +164,7 @@ let tickets_of_origination ctxt ~preorigination ~storage_type ~storage = let tickets_of_operation ctxt (Script_typed_ir.Internal_operation {source = _; operation; nonce = _}) = - match operation with + match[@coq_match_with_default] operation with | Transaction_to_implicit _ -> return (None, ctxt) | Transaction_to_smart_contract { diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index 152e51c1c635f..bc717eb8c5ee7 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -110,7 +110,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 @@ -145,7 +145,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 -> @@ -182,11 +182,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, _) -> @@ -221,7 +221,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 -> @@ -229,11 +229,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 -> @@ -242,12 +242,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 @@ -274,7 +274,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 @@ -308,7 +308,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 -> context -> @@ -321,11 +321,11 @@ 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] [@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 @@ -333,7 +333,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 @@ -341,10 +341,12 @@ module Ticket_collection = struct r acc k) - | Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _) -> ( + | ( Union_ht (htyl, htyr), + Union_t (tyl, tyr, _, _), + (x : _ Script_typed_ir.union) ) -> ( match x with | L v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt htyl @@ -353,7 +355,7 @@ module Ticket_collection = struct acc k | R v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt htyr @@ -361,10 +363,10 @@ module Ticket_collection = struct v acc k) - | Option_ht el_hty, Option_t (el_ty, _, _) -> ( + | Option_ht el_hty, Option_t (el_ty, _, _), (x : _ option) -> ( match x with | Some x -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt el_hty @@ -373,7 +375,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_list.t) -> let elements = Script_list.to_list x in (tickets_of_list [@ocaml.tailcall]) ctxt @@ -383,9 +385,9 @@ 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 : _ map) -> (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty @@ -399,14 +401,20 @@ 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 : _ big_map) -> if include_lazy then - (tickets_of_big_map [@ocaml.tailcall]) ctxt val_hty key_ty x acc k + (tickets_of_big_map [@ocaml.tailcall] [@coq_implicit "v" "__10"]) + 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. context -> include_lazy:bool -> @@ -420,7 +428,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 @@ -438,7 +446,7 @@ module Ticket_collection = struct k) | [] -> (k [@ocaml.tailcall]) ctxt acc - and tickets_of_map : + and[@coq_mutual_as_notation] tickets_of_map : type k v vc ret. include_lazy:bool -> context -> @@ -463,7 +471,7 @@ module Ticket_collection = struct acc k - and tickets_of_big_map : + and[@coq_mutual_as_notation] tickets_of_big_map : type k v ret. context -> v Ticket_inspection.has_tickets -> @@ -510,7 +518,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 @@ -518,6 +526,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) -> @@ -533,8 +542,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 ~elab_conf:Script_ir_translator_config.(make ~legacy:true ()) ~allow_forged:true diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.mli b/src/proto_alpha/lib_protocol/ticket_scanner.mli index 49d3a11b7eeb2..b4b79b21aa4c6 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/token.ml b/src/proto_alpha/lib_protocol/token.ml index 072cb8e262a42..edf6a15875dbf 100644 --- a/src/proto_alpha/lib_protocol/token.ml +++ b/src/proto_alpha/lib_protocol/token.ml @@ -24,72 +24,74 @@ (*****************************************************************************) 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 - | `Sc_rollup_refutation_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 + | Sc_rollup_refutation_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 = @@ -98,45 +100,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) @@ -146,10 +148,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 @@ -161,51 +163,51 @@ let credit ctxt dest amount origin = let spend ctxt src 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 - | `Sc_rollup_refutation_rewards -> Sc_rollup_refutation_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 + | Sc_rollup_refutation_rewards -> Sc_rollup_refutation_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 @@ -238,9 +240,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_alpha/lib_protocol/token.mli b/src/proto_alpha/lib_protocol/token.mli index 6610e1e74324b..9d704665dce54 100644 --- a/src/proto_alpha/lib_protocol/token.mli +++ b/src/proto_alpha/lib_protocol/token.mli @@ -43,44 +43,46 @@ 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 - | `Sc_rollup_refutation_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 + | Sc_rollup_refutation_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 @@ -111,8 +113,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 @@ -139,7 +141,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_alpha/lib_protocol/tx_rollup_commitment_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml index 9ac9323952dd4..2069bccb19594 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/tx_rollup_commitment_repr.mli b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli index 8a396f24d3986..277059cb20e75 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml index 797c2a7f25a02..35cf8345427b3 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_alpha/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 = tzfail (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 -> tzfail (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_alpha/lib_protocol/tx_rollup_commitment_storage.mli b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli index 41af2357a0128..530b827607550 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/tx_rollup_errors_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml index f3814a468f8e6..802efa3ccdf00 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml +++ b/src/proto_alpha/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 : Saturation_repr.may_saturate Saturation_repr.t; @@ -414,14 +418,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)) @@ -596,16 +600,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_alpha/lib_protocol/tx_rollup_gas.ml b/src/proto_alpha/lib_protocol/tx_rollup_gas.ml index 6ae5cb451f107..bfa38362a572a 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_gas.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/tx_rollup_l2_address.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_address.ml index 8959062241ae4..76b7387284105 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_address.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_address.ml @@ -25,7 +25,7 @@ (* *) (*****************************************************************************) -include Bls.Public_key_hash +include Bls.Public_key_hash [@@coq_include_without "size"] type address = t diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index f7b1a7d4edcfb..57aca966158c1 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/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.Public_key.t) @@ -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 = @@ -536,9 +606,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 @@ -572,11 +642,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} -> @@ -608,7 +678,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 @@ -623,10 +694,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 @@ -649,12 +720,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 -> @@ -684,8 +757,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 = err; _} -> ( + match err 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 @@ -694,10 +776,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 @@ -730,9 +812,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 = @@ -757,7 +839,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_alpha/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli index 1f71544e556f6..43d545f1cd9c0 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli +++ b/src/proto_alpha/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_alpha/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml index e37f41c55a34e..058ae52f2a0f7 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml @@ -76,6 +76,7 @@ module V1 = struct ticket_hash : 'status Ticket_indexable.t; qty : Tx_rollup_l2_qty.t; } + [@@coq_force_gadt] type ('signer, 'content) operation = { signer : 'signer Signer_indexable.t; @@ -131,7 +132,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)) @@ -141,30 +142,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_alpha/lib_protocol/tx_rollup_l2_batch.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli index de97740fb5c9d..6276671cb2094 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli +++ b/src/proto_alpha/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} *) @@ -117,6 +103,7 @@ module V1 : sig (** A [Transfer] moves [qty] of the tickets represented by [ticket_hash] from the operation's signer in layer-2 to [destination] in layer-2. *) + [@@coq_force_gadt] type ('signer, 'content) operation = { signer : 'signer Signer_indexable.t; diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index 5173ce5c768b8..76f570346d48f 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -109,7 +109,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 @@ -165,7 +165,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 = @@ -265,7 +266,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 @@ -292,17 +298,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 @@ -329,17 +340,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_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml index 26de4e453ae09..14e0fcf4fac8c 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml @@ -24,8 +24,6 @@ (* *) (*****************************************************************************) -type signature = Bls.t - module Ticket_indexable = Indexable.Make (Alpha_context.Ticket_hash) (** An integer used to identified a layer-2 address. See @@ -147,198 +145,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. +type created_existed = Created | Existed - 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]. *) +(** 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 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. + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m + val ( let* ) : 'a m -> ('a -> '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 + (** [let*?] is for binding the value from Result-only + expressions into the storage monad. *) + val ( let*? ) : ('a, error) result -> ('a -> '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 + (** [fail err] shortcuts the current computation by raising an + error. - (** [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 + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m - (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) - val fail_unless : bool -> error -> unit 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 - (** [fail_when cond err] raises [err] iff [cond] is [true]. *) - val fail_when : bool -> error -> unit m - end + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m - (** [bls_aggregate_verify] allows to verify the aggregated signature - of a batch. *) - val bls_verify : (Bls.Public_key.t * bytes) list -> signature -> bool 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 - (** 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 + (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) + val fail_unless : bool -> error -> unit m - (** [incr_counter ctxt idx] increments the counter of the - address indexed by [idx]. - - This function can fail with [Counter_overflow] iff the counter - has reached the [Int64.max_int] limit. + (** [fail_when cond err] raises [err] iff [cond] is [true]. *) + val fail_when : bool -> error -> unit m +end - 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 +module type ADDRESS_METADATA = sig + type t - (** [init_with_public_key ctxt idx pk] initializes the metadata - associated to the address indexed by [idx]. + type 'a m - 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.Public_key.t -> t m + (** [get ctxt idx] returns the current metadata associated to the + address indexed by [idx]. *) + val get : t -> address_index -> metadata option m - (**/**) + (** [incr_counter ctxt idx] increments the counter of the + address indexed by [idx]. - module Internal_for_tests : sig - val set : t -> address_index -> metadata -> t m - end - end + This function can fail with [Counter_overflow] iff the counter + has reached the [Int64.max_int] limit. - (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + 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 - 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 + (** [init_with_public_key ctxt idx pk] initializes the metadata + associated to the address indexed by [idx]. - (** [get ctxt addr] returns the index associated to [addr], if - any. *) - val get : t -> Tx_rollup_l2_address.t -> address_index option m + 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.Public_key.t -> t 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. @@ -352,9 +289,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. @@ -364,11 +301,77 @@ 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.Public_key.t * bytes) list -> Bls.t -> 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 + +type signature = Bls.t diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml index 4a81f9cd41808..e5bf65a5d63bd 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml @@ -25,6 +25,37 @@ (* *) (*****************************************************************************) +(** The necessary monadic operators the monad of the storage backend + is required to provide. *) +module type SYNTAX = sig + 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 +75,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 '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_alpha/lib_protocol/tx_rollup_l2_verifier.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml index 50270fbe30c57..8ecb061b8d504 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml +++ b/src/proto_alpha/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,9 @@ 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 ~proof_length ~max_proof_size ctxt parameters - agreed (proof : Tx_rollup_l2_proof.t) message = +let[@coq_axiom_with_reason "polymorphic variant"] compute_proof_after_hash + ~proof_length ~max_proof_size ctxt parameters agreed + (proof : Tx_rollup_l2_proof.t) message = let message_length = Data_encoding.Binary.length Tx_rollup_message.encoding message in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml index f79d341c76426..d2cda7c218389 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml @@ -37,6 +37,7 @@ let get_deposit_parameters : ((a ticket, tx_rollup_l2_address) pair, comparable) ty -> (a ticket, tx_rollup_l2_address) pair -> deposit_parameters = - fun (Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _)) - (ticket, l2_destination) -> + fun [@coq_match_with_default] (Pair_t + (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _)) + (ticket, l2_destination) -> {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination} diff --git a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml index 104b9f1e00d1d..ba4e6b1ece854 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml +++ b/src/proto_alpha/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_alpha/lib_protocol/validate.ml b/src/proto_alpha/lib_protocol/validate.ml index 128c4979492ba..b50a471246f5b 100644 --- a/src/proto_alpha/lib_protocol/validate.ml +++ b/src/proto_alpha/lib_protocol/validate.ml @@ -470,7 +470,7 @@ type validation_state = { let ok_unit = Result_syntax.return_unit -let init_info ctxt mode chain_id all_expected_consensus_characteristics = +let init_info_aux ctxt mode chain_id all_expected_consensus_characteristics = { ctxt; mode; @@ -719,7 +719,7 @@ module Consensus = struct let check_preendorsement vi ~check_signature (operation : Kind.preendorsement operation) = let open Lwt_result_syntax in - let (Single (Preendorsement consensus_content)) = + let[@coq_match_with_default] (Single (Preendorsement consensus_content)) = operation.protocol_data.contents in let kind = Preendorsement in @@ -757,7 +757,7 @@ module Consensus = struct let check_preendorsement_conflict vs oph (op : Kind.preendorsement operation) = - let (Single (Preendorsement consensus_content)) = + let[@coq_match_with_default] (Single (Preendorsement consensus_content)) = op.protocol_data.contents in match @@ -777,7 +777,7 @@ module Consensus = struct Conflicting_consensus_operation {kind = Preendorsement; conflict}) let add_preendorsement vs oph (op : Kind.preendorsement operation) = - let (Single (Preendorsement consensus_content)) = + let[@coq_match_with_default] (Single (Preendorsement consensus_content)) = op.protocol_data.contents in let preendorsements_seen = @@ -810,7 +810,7 @@ module Consensus = struct let remove_preendorsement vs (operation : Kind.preendorsement operation) = (* As we are in mempool mode, we do not update [locked_round_evidence]. *) - let (Single (Preendorsement consensus_content)) = + let[@coq_match_with_default] (Single (Preendorsement consensus_content)) = operation.protocol_data.contents in let preendorsements_seen = @@ -906,7 +906,7 @@ module Consensus = struct let check_normal_endorsement vi ~check_signature (operation : Kind.endorsement operation) = let open Lwt_result_syntax in - let (Single (Endorsement consensus_content)) = + let[@coq_match_with_default] (Single (Endorsement consensus_content)) = operation.protocol_data.contents in let kind = Endorsement in @@ -978,7 +978,7 @@ module Consensus = struct let check_endorsement vi ~check_signature (operation : Kind.endorsement operation) = let open Lwt_result_syntax in - let (Single (Endorsement consensus_content)) = + let[@coq_match_with_default] (Single (Endorsement consensus_content)) = operation.protocol_data.contents in match @@ -1010,7 +1010,7 @@ module Consensus = struct let check_endorsement_conflict vs oph (operation : Kind.endorsement operation) = - let (Single (Endorsement consensus_content)) = + let[@coq_match_with_default] (Single (Endorsement consensus_content)) = operation.protocol_data.contents in if is_normal_endorsement_assuming_valid vs consensus_content then @@ -1026,7 +1026,9 @@ module Consensus = struct let add_endorsement vs oph (op : Kind.endorsement operation) endorsement_kind = - let (Single (Endorsement consensus_content)) = op.protocol_data.contents in + let[@coq_match_with_default] (Single (Endorsement consensus_content)) = + op.protocol_data.contents + in match endorsement_kind with | Grandparent_endorsement -> add_grandparent_endorsement vs oph consensus_content @@ -1042,7 +1044,9 @@ module Consensus = struct } let remove_endorsement vs (op : Kind.endorsement operation) = - let (Single (Endorsement consensus_content)) = op.protocol_data.contents in + let[@coq_match_with_default] (Single (Endorsement consensus_content)) = + op.protocol_data.contents + in if is_normal_endorsement_assuming_valid vs consensus_content then remove_normal_endorsement vs consensus_content else remove_grandparent_endorsement vs consensus_content @@ -1058,7 +1062,9 @@ module Consensus = struct operation should be merged with an endorsement or at least refined. *) let open Lwt_result_syntax in - let (Single (Dal_attestation op)) = operation.protocol_data.contents in + let[@coq_match_with_default] (Single (Dal_attestation op)) = + operation.protocol_data.contents + in let*? () = (* Note that this function checks the dal feature flag. *) Dal_apply.validate_attestation vi.ctxt op @@ -1067,7 +1073,9 @@ module Consensus = struct let check_dal_attestation_conflict vs oph (operation : Kind.dal_attestation operation) = - let (Single (Dal_attestation {attestor; attestation = _; level = _})) = + let[@coq_match_with_default] (Single + (Dal_attestation + {attestor; attestation = _; level = _})) = operation.protocol_data.contents in match @@ -1087,7 +1095,9 @@ module Consensus = struct Conflicting_consensus_operation {kind = Dal_attestation; conflict}) let add_dal_attestation vs oph (operation : Kind.dal_attestation operation) = - let (Single (Dal_attestation {attestor; attestation = _; level = _})) = + let[@coq_match_with_default] (Single + (Dal_attestation + {attestor; attestation = _; level = _})) = operation.protocol_data.contents in { @@ -1104,7 +1114,9 @@ module Consensus = struct } let remove_dal_attestation vs (operation : Kind.dal_attestation operation) = - let (Single (Dal_attestation {attestor; attestation = _; level = _})) = + let[@coq_match_with_default] (Single + (Dal_attestation + {attestor; attestation = _; level = _})) = operation.protocol_data.contents in let dal_attestation_seen = @@ -1150,7 +1162,7 @@ module Consensus = struct let validate_preendorsement ~check_signature info operation_state block_state oph (operation : Kind.preendorsement operation) = let open Lwt_result_syntax in - let (Single (Preendorsement consensus_content)) = + let[@coq_match_with_default] (Single (Preendorsement consensus_content)) = operation.protocol_data.contents in let* voting_power = check_preendorsement info ~check_signature operation in @@ -1331,7 +1343,8 @@ module Voting = struct let check_proposals vi ~check_signature (operation : Kind.proposals operation) = let open Lwt_result_syntax in - let (Single (Proposals {source; period; proposals})) = + let[@coq_match_with_default] (Single + (Proposals {source; period; proposals})) = operation.protocol_data.contents in let* current_period = Voting_period.get_current vi.ctxt in @@ -1368,7 +1381,9 @@ module Voting = struct ordinary manager). *) let check_proposals_conflict vs oph (operation : Kind.proposals operation) = let open Result_syntax in - let (Single (Proposals {source; _})) = operation.protocol_data.contents in + let[@coq_match_with_default] (Single (Proposals {source; _})) = + operation.protocol_data.contents + in match Signature.Public_key_hash.Map.find_opt source @@ -1384,7 +1399,9 @@ module Voting = struct error Validate_errors.Voting.(Conflicting_proposals conflict) let add_proposals vs oph (operation : Kind.proposals operation) = - let (Single (Proposals {source; _})) = operation.protocol_data.contents in + let[@coq_match_with_default] (Single (Proposals {source; _})) = + operation.protocol_data.contents + in let proposals_seen = Signature.Public_key_hash.Map.add source @@ -1395,7 +1412,9 @@ module Voting = struct {vs with voting_state} let remove_proposals vs (operation : Kind.proposals operation) = - let (Single (Proposals {source; _})) = operation.protocol_data.contents in + let[@coq_match_with_default] (Single (Proposals {source; _})) = + operation.protocol_data.contents + in let proposals_seen = Signature.Public_key_hash.Map.remove source vs.voting_state.proposals_seen in @@ -1453,7 +1472,9 @@ module Voting = struct incorrectly signed. *) let check_ballot vi ~check_signature (operation : Kind.ballot operation) = let open Lwt_result_syntax in - let (Single (Ballot {source; period; proposal; ballot = _})) = + let[@coq_match_with_default] (Single + (Ballot + {source; period; proposal; ballot = _})) = operation.protocol_data.contents in let* () = check_ballot_source_is_registered vi.ctxt source in @@ -1476,7 +1497,9 @@ module Voting = struct @return [Error Operation_conflict] if the current block/mempool already contains a Ballot operation from the same source. *) let check_ballot_conflict vs oph (operation : Kind.ballot operation) = - let (Single (Ballot {source; _})) = operation.protocol_data.contents in + let[@coq_match_with_default] (Single (Ballot {source; _})) = + operation.protocol_data.contents + in match Signature.Public_key_hash.Map.find_opt source vs.voting_state.ballots_seen with @@ -1489,7 +1512,9 @@ module Voting = struct | Error conflict -> error (Conflicting_ballot conflict) let add_ballot vs oph (operation : Kind.ballot operation) = - let (Single (Ballot {source; _})) = operation.protocol_data.contents in + let[@coq_match_with_default] (Single (Ballot {source; _})) = + operation.protocol_data.contents + in let ballots_seen = Signature.Public_key_hash.Map.add source oph vs.voting_state.ballots_seen in @@ -1497,7 +1522,9 @@ module Voting = struct {vs with voting_state} let remove_ballot vs (operation : Kind.ballot operation) = - let (Single (Ballot {source; _})) = operation.protocol_data.contents in + let[@coq_match_with_default] (Single (Ballot {source; _})) = + operation.protocol_data.contents + in let ballots_seen = Signature.Public_key_hash.Map.remove source vs.voting_state.ballots_seen in @@ -1508,7 +1535,9 @@ module Anonymous = struct open Validate_errors.Anonymous let check_activate_account vi (operation : Kind.activate_account operation) = - let (Single (Activate_account {id = edpkh; activation_code})) = + let[@coq_match_with_default] (Single + (Activate_account + {id = edpkh; activation_code})) = operation.protocol_data.contents in let open Lwt_result_syntax in @@ -1521,7 +1550,7 @@ module Anonymous = struct let check_activate_account_conflict vs oph (operation : Kind.activate_account operation) = - let (Single (Activate_account {id = edpkh; _})) = + let[@coq_match_with_default] (Single (Activate_account {id = edpkh; _})) = operation.protocol_data.contents in match @@ -1537,14 +1566,15 @@ module Anonymous = struct (operation : Kind.activate_account operation) = function | Ok () -> ok_unit | Error conflict -> - let (Single (Activate_account {id = edpkh; _})) = + let[@coq_match_with_default] (Single (Activate_account {id = edpkh; _})) + = operation.protocol_data.contents in error (Conflicting_activation {edpkh; conflict}) let add_activate_account vs oph (operation : Kind.activate_account operation) = - let (Single (Activate_account {id = edpkh; _})) = + let[@coq_match_with_default] (Single (Activate_account {id = edpkh; _})) = operation.protocol_data.contents in let activation_pkhs_seen = @@ -1556,7 +1586,7 @@ module Anonymous = struct {vs with anonymous_state = {vs.anonymous_state with activation_pkhs_seen}} let remove_activate_account vs (operation : Kind.activate_account operation) = - let (Single (Activate_account {id = edpkh; _})) = + let[@coq_match_with_default] (Single (Activate_account {id = edpkh; _})) = operation.protocol_data.contents in let activation_pkhs_seen = @@ -1588,7 +1618,9 @@ module Anonymous = struct (op1 : kind Kind.consensus Operation.t) (op2 : kind Kind.consensus Operation.t) = let open Lwt_result_syntax 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 op1_hash = Operation.hash op1 in @@ -1639,7 +1671,9 @@ module Anonymous = struct let check_double_preendorsement_evidence vi (operation : Kind.double_preendorsement_evidence operation) = - let (Single (Double_preendorsement_evidence {op1; op2})) = + let[@coq_match_with_default] (Single + (Double_preendorsement_evidence {op1; op2})) + = operation.protocol_data.contents in check_double_endorsing_evidence @@ -1650,14 +1684,15 @@ module Anonymous = struct let check_double_endorsement_evidence vi (operation : Kind.double_endorsement_evidence operation) = - let (Single (Double_endorsement_evidence {op1; op2})) = + let[@coq_match_with_default] (Single + (Double_endorsement_evidence {op1; op2})) = operation.protocol_data.contents in check_double_endorsing_evidence ~consensus_operation:Endorsement vi op1 op2 let check_double_endorsing_evidence_conflict (type kind) vs oph (op1 : kind Kind.consensus Operation.t) = - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement e1) | Single (Endorsement e1) -> ( match Double_endorsing_evidence_map.find @@ -1670,14 +1705,16 @@ module Anonymous = struct let check_double_preendorsement_evidence_conflict vs oph (operation : Kind.double_preendorsement_evidence operation) = - let (Single (Double_preendorsement_evidence {op1; _})) = + let[@coq_match_with_default] (Single + (Double_preendorsement_evidence {op1; _})) = operation.protocol_data.contents in check_double_endorsing_evidence_conflict vs oph op1 let check_double_endorsement_evidence_conflict vs oph (operation : Kind.double_endorsement_evidence operation) = - let (Single (Double_endorsement_evidence {op1; _})) = + let[@coq_match_with_default] (Single (Double_endorsement_evidence {op1; _})) + = operation.protocol_data.contents in check_double_endorsing_evidence_conflict vs oph op1 @@ -1688,7 +1725,7 @@ module Anonymous = struct let add_double_endorsing_evidence (type kind) vs oph (op1 : kind Kind.consensus Operation.t) = - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement e1) | Single (Endorsement e1) -> let double_endorsing_evidences_seen = Double_endorsing_evidence_map.add @@ -1704,21 +1741,23 @@ module Anonymous = struct let add_double_endorsement_evidence vs oph (operation : Kind.double_endorsement_evidence operation) = - let (Single (Double_endorsement_evidence {op1; _})) = + let[@coq_match_with_default] (Single (Double_endorsement_evidence {op1; _})) + = operation.protocol_data.contents in add_double_endorsing_evidence vs oph op1 let add_double_preendorsement_evidence vs oph (operation : Kind.double_preendorsement_evidence operation) = - let (Single (Double_preendorsement_evidence {op1; _})) = + let[@coq_match_with_default] (Single + (Double_preendorsement_evidence {op1; _})) = operation.protocol_data.contents in add_double_endorsing_evidence vs oph op1 let remove_double_endorsing_evidence (type kind) vs (op : kind Kind.consensus Operation.t) = - match op.protocol_data.contents with + match[@coq_match_with_default] op.protocol_data.contents with | Single (Endorsement e) | Single (Preendorsement e) -> let double_endorsing_evidences_seen = Double_endorsing_evidence_map.remove @@ -1732,14 +1771,16 @@ module Anonymous = struct let remove_double_preendorsement_evidence vs (operation : Kind.double_preendorsement_evidence operation) = - let (Single (Double_preendorsement_evidence {op1; _})) = + let[@coq_match_with_default] (Single + (Double_preendorsement_evidence {op1; _})) = operation.protocol_data.contents in remove_double_endorsing_evidence vs op1 let remove_double_endorsement_evidence vs (operation : Kind.double_endorsement_evidence operation) = - let (Single (Double_endorsement_evidence {op1; _})) = + let[@coq_match_with_default] (Single (Double_endorsement_evidence {op1; _})) + = operation.protocol_data.contents in remove_double_endorsing_evidence vs op1 @@ -1747,7 +1788,7 @@ module Anonymous = struct let check_double_baking_evidence vi (operation : Kind.double_baking_evidence operation) = let open Lwt_result_syntax in - let (Single (Double_baking_evidence {bh1; bh2})) = + let[@coq_match_with_default] (Single (Double_baking_evidence {bh1; bh2})) = operation.protocol_data.contents in let hash1 = Block_header.hash bh1 in @@ -1802,7 +1843,7 @@ module Anonymous = struct let check_double_baking_evidence_conflict vs oph (operation : Kind.double_baking_evidence operation) = - let (Single (Double_baking_evidence {bh1; _})) = + let[@coq_match_with_default] (Single (Double_baking_evidence {bh1; _})) = operation.protocol_data.contents in let bh1_fitness = @@ -1825,7 +1866,7 @@ module Anonymous = struct let add_double_baking_evidence vs oph (operation : Kind.double_baking_evidence operation) = - let (Single (Double_baking_evidence {bh1; _})) = + let[@coq_match_with_default] (Single (Double_baking_evidence {bh1; _})) = operation.protocol_data.contents in let bh1_fitness = @@ -1848,7 +1889,7 @@ module Anonymous = struct let remove_double_baking_evidence vs (operation : Kind.double_baking_evidence operation) = - let (Single (Double_baking_evidence {bh1; _})) = + let[@coq_match_with_default] (Single (Double_baking_evidence {bh1; _})) = operation.protocol_data.contents in let bh1_fitness, level = @@ -1874,7 +1915,9 @@ module Anonymous = struct let check_drain_delegate info ~check_signature (operation : Kind.drain_delegate Operation.t) = let open Lwt_result_syntax in - let (Single (Drain_delegate {delegate; destination; consensus_key})) = + let[@coq_match_with_default] (Single + (Drain_delegate + {delegate; destination; consensus_key})) = operation.protocol_data.contents in let*! is_registered = Delegate.registered info.ctxt delegate in @@ -1937,7 +1980,7 @@ module Anonymous = struct let check_drain_delegate_conflict state oph (operation : Kind.drain_delegate Operation.t) = - let (Single (Drain_delegate {delegate; _})) = + let[@coq_match_with_default] (Single (Drain_delegate {delegate; _})) = operation.protocol_data.contents in match @@ -1951,7 +1994,7 @@ module Anonymous = struct let wrap_drain_delegate_conflict (operation : Kind.drain_delegate Operation.t) = - let (Single (Drain_delegate {delegate; _})) = + let[@coq_match_with_default] (Single (Drain_delegate {delegate; _})) = operation.protocol_data.contents in function @@ -1960,7 +2003,7 @@ module Anonymous = struct let add_drain_delegate state oph (operation : Kind.drain_delegate Operation.t) = - let (Single (Drain_delegate {delegate; _})) = + let[@coq_match_with_default] (Single (Drain_delegate {delegate; _})) = operation.protocol_data.contents in let managers_seen = @@ -1973,7 +2016,7 @@ module Anonymous = struct let remove_drain_delegate state (operation : Kind.drain_delegate Operation.t) = - let (Single (Drain_delegate {delegate; _})) = + let[@coq_match_with_default] (Single (Drain_delegate {delegate; _})) = operation.protocol_data.contents in let managers_seen = @@ -1986,7 +2029,9 @@ module Anonymous = struct let check_seed_nonce_revelation vi (operation : Kind.seed_nonce_revelation operation) = let open Lwt_result_syntax in - let (Single (Seed_nonce_revelation {level = commitment_raw_level; nonce})) = + let[@coq_match_with_default] (Single + (Seed_nonce_revelation + {level = commitment_raw_level; nonce})) = operation.protocol_data.contents in let commitment_level = Level.from_raw vi.ctxt commitment_raw_level in @@ -1995,7 +2040,9 @@ module Anonymous = struct let check_seed_nonce_revelation_conflict vs oph (operation : Kind.seed_nonce_revelation operation) = - let (Single (Seed_nonce_revelation {level = commitment_raw_level; _})) = + let[@coq_match_with_default] (Single + (Seed_nonce_revelation + {level = commitment_raw_level; _})) = operation.protocol_data.contents in match @@ -2013,7 +2060,9 @@ module Anonymous = struct let add_seed_nonce_revelation vs oph (operation : Kind.seed_nonce_revelation operation) = - let (Single (Seed_nonce_revelation {level = commitment_raw_level; _})) = + let[@coq_match_with_default] (Single + (Seed_nonce_revelation + {level = commitment_raw_level; _})) = operation.protocol_data.contents in let seed_nonce_levels_seen = @@ -2027,7 +2076,9 @@ module Anonymous = struct let remove_seed_nonce_revelation vs (operation : Kind.seed_nonce_revelation operation) = - let (Single (Seed_nonce_revelation {level = commitment_raw_level; _})) = + let[@coq_match_with_default] (Single + (Seed_nonce_revelation + {level = commitment_raw_level; _})) = operation.protocol_data.contents in let seed_nonce_levels_seen = @@ -2040,7 +2091,7 @@ module Anonymous = struct let check_vdf_revelation vi (operation : Kind.vdf_revelation operation) = let open Lwt_result_syntax in - let (Single (Vdf_revelation {solution})) = + let[@coq_match_with_default] (Single (Vdf_revelation {solution})) = operation.protocol_data.contents in let* () = Seed.check_vdf vi.ctxt solution in @@ -2129,7 +2180,7 @@ module Manager = struct Manager_counter.t -> kind Kind.manager contents_list -> unit tzresult = - fun expected_source previous_counter -> function + fun expected_source previous_counter -> function[@coq_match_with_default] | Single (Manager_operation {operation = Reveal _key; _}) -> error Incorrect_reveal_position | Cons (Manager_operation {operation = Reveal _key; _}, _res) -> @@ -2156,7 +2207,7 @@ module Manager = struct kind Kind.manager contents_list -> (public_key_hash * public_key option * Manager_counter.t) tzresult = fun contents_list -> - match contents_list with + match[@coq_match_with_default] contents_list with | Single (Manager_operation {source; operation = Reveal key; counter; _}) -> ok (source, Some key, counter) @@ -2262,7 +2313,8 @@ module Manager = struct let validate_tx_rollup_dispatch_tickets vi remaining_gas operation = let open Result_syntax in let* () = assert_tx_rollup_feature_enabled vi in - let (Tx_rollup_dispatch_tickets {tickets_info; message_result_path; _}) = + let[@coq_match_with_default] (Tx_rollup_dispatch_tickets + {tickets_info; message_result_path; _}) = operation in let Constants.Parametric. @@ -2271,7 +2323,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 @@ -2302,9 +2354,13 @@ module Manager = struct let validate_tx_rollup_rejection vi operation = let open Result_syntax in let* () = assert_tx_rollup_feature_enabled vi in - let (Tx_rollup_rejection - {message_path; message_result_path; previous_message_result_path; _}) - = + let[@coq_match_with_default] (Tx_rollup_rejection + { + message_path; + message_result_path; + previous_message_result_path; + _; + }) = operation in let Constants.Parametric.{max_messages_per_inbox; _} = @@ -2312,18 +2368,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 @@ -2344,8 +2400,15 @@ module Manager = struct let check_contents (type kind) vi batch_state (contents : kind Kind.manager contents) remaining_block_gas = let open Lwt_result_syntax in - let (Manager_operation - {source; fee; counter = _; operation; gas_limit; storage_limit}) = + let[@coq_match_with_default] (Manager_operation + { + source; + fee; + counter = _; + operation; + gas_limit; + storage_limit; + }) = contents in let*? () = check_gas_limit vi ~gas_limit in @@ -2485,7 +2548,7 @@ module Manager = struct let check_manager_operation_conflict (type kind) vs oph (operation : kind Kind.manager operation) = let source = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Manager_operation {source; _}) | Cons (Manager_operation {source; _}, _) -> source @@ -2503,7 +2566,7 @@ module Manager = struct let wrap_check_manager_operation_conflict (type kind) (operation : kind Kind.manager operation) = let source = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Manager_operation {source; _}) | Cons (Manager_operation {source; _}, _) -> source @@ -2515,7 +2578,7 @@ module Manager = struct let add_manager_operation (type kind) vs oph (operation : kind Kind.manager operation) = let source = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Manager_operation {source; _}) | Cons (Manager_operation {source; _}, _) -> source @@ -2550,7 +2613,7 @@ module Manager = struct let remove_manager_operation (type kind) vs (operation : kind Kind.manager operation) = let source = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Manager_operation {source; _}) | Cons (Manager_operation {source; _}, _) -> source @@ -2583,7 +2646,7 @@ end let init_validation_state ctxt mode chain_id all_expected_consensus_features ~predecessor_level = - let info = init_info ctxt mode chain_id all_expected_consensus_features in + let info = init_info_aux ctxt mode chain_id all_expected_consensus_features in let operation_state = init_operation_conflict_state ~predecessor_level in let block_state = init_block_state info in {info; operation_state; block_state} @@ -2783,7 +2846,7 @@ let begin_no_predecessor_info ctxt chain_id = let check_operation ?(check_signature = true) info (type kind) (operation : kind operation) : unit tzresult Lwt.t = let open Lwt_result_syntax in - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> let* (_voting_power : int) = Consensus.check_preendorsement info ~check_signature operation @@ -2839,7 +2902,7 @@ let check_operation ?(check_signature = true) info (type kind) let check_operation_conflict (type kind) operation_conflict_state oph (operation : kind operation) = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> Consensus.check_preendorsement_conflict operation_conflict_state @@ -2905,7 +2968,7 @@ let check_operation_conflict (type kind) operation_conflict_state oph let add_valid_operation operation_conflict_state oph (type kind) (operation : kind operation) = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> Consensus.add_preendorsement operation_conflict_state oph operation | Single (Endorsement consensus_content) -> @@ -2962,7 +3025,7 @@ let add_valid_operation operation_conflict_state oph (type kind) - this function is only valid for the mempool mode. *) let remove_operation operation_conflict_state (type kind) (operation : kind operation) = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> Consensus.remove_preendorsement operation_conflict_state operation | Single (Endorsement _) -> @@ -3048,7 +3111,7 @@ let validate_operation ?(check_signature = true) return {info; operation_state; block_state} | Partial_validation _, _ | Mempool, _ | Construction _, _ | Application _, _ -> ( - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> Consensus.validate_preendorsement ~check_signature diff --git a/src/proto_alpha/lib_protocol/zk_rollup_apply.ml b/src/proto_alpha/lib_protocol/zk_rollup_apply.ml index 1e14ee3c14aee..f1b7cc01889a0 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_apply.ml +++ b/src/proto_alpha/lib_protocol/zk_rollup_apply.ml @@ -86,11 +86,11 @@ let originate ~ctxt_before_op ~ctxt ~public_parameters ~circuits_info individual parts submitted as part of a Zk_rollup_publish operation. *) let parse_ticket ~ticketer ~contents ~ty ctxt = Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data - ctxt - contents_type - (Micheline.root contents) + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data + ctxt + contents_type + (Micheline.root contents) [@coq_type_annotation]) >>=? fun (contents, ctxt) -> return @@ (ctxt, Ticket_token.Ex_token {ticketer; contents_type; contents}) diff --git a/src/proto_alpha/lib_protocol/zk_rollup_parameters.ml b/src/proto_alpha/lib_protocol/zk_rollup_parameters.ml index d41389d53e41f..0e3d1b71912e9 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_parameters.ml +++ b/src/proto_alpha/lib_protocol/zk_rollup_parameters.ml @@ -37,7 +37,7 @@ let get_deposit_parameters : deposit_parameters tzresult = fun ty contents -> let open Script_typed_ir in - match (ty, contents) with + match[@coq_match_with_default] (ty, contents) with | Pair_t (Ticket_t (ty, _), Bytes_t, _, _), (ticket, op_bytes) -> ( match Data_encoding.Binary.of_bytes_opt diff --git a/src/proto_demo_counter/lib_protocol/main.ml b/src/proto_demo_counter/lib_protocol/main.ml index f9c997b9661e8..cecb917b75416 100644 --- a/src/proto_demo_counter/lib_protocol/main.ml +++ b/src/proto_demo_counter/lib_protocol/main.ml @@ -266,10 +266,12 @@ module Mempool = struct type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { diff --git a/src/proto_demo_noops/lib_protocol/main.ml b/src/proto_demo_noops/lib_protocol/main.ml index f194751ac3a6b..e201e73c006da 100644 --- a/src/proto_demo_noops/lib_protocol/main.ml +++ b/src/proto_demo_noops/lib_protocol/main.ml @@ -167,10 +167,12 @@ module Mempool = struct type validation_info = unit + type keep_or_replace = Keep | Replace + type conflict_handler = existing_operation:Operation_hash.t * operation -> new_operation:Operation_hash.t * operation -> - [`Keep | `Replace] + keep_or_replace type operation_conflict = | Operation_conflict of { -- GitLab From e95406eb7535d1f7195165b891b652600dd42bd2 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 24 Nov 2022 17:17:21 +0100 Subject: [PATCH 2/3] fixing compilation in Coq except for the interpreter --- src/lib_protocol_environment/sigs/v8.in.ml | 125 +++++----- src/lib_protocol_environment/sigs/v8.ml | 213 +++++++++--------- .../lib_plugin/script_interpreter_logging.ml | 8 +- src/proto_alpha/lib_protocol/alpha_context.ml | 4 - .../lib_protocol/alpha_context.mli | 15 +- src/proto_alpha/lib_protocol/apply_results.ml | 2 +- src/proto_alpha/lib_protocol/dal_slot_repr.ml | 17 +- .../lib_protocol/michelson_v1_gas_costs.ml | 1 - .../lib_protocol/operation_repr.ml | 5 +- .../lib_protocol/operation_repr.mli | 3 +- src/proto_alpha/lib_protocol/raw_context.ml | 29 +-- src/proto_alpha/lib_protocol/raw_context.mli | 8 +- .../lib_protocol/raw_context_intf.ml | 49 ++-- .../lib_protocol/sc_rollup_PVM_sig.ml | 26 +-- .../lib_protocol/sc_rollup_arith.ml | 3 +- .../sc_rollup_dissection_chunk_repr.ml | 4 +- ...up_inbox_merkelized_payload_hashes_repr.ml | 12 +- ...p_inbox_merkelized_payload_hashes_repr.mli | 2 +- .../sc_rollup_inbox_message_repr.mli | 2 +- .../lib_protocol/sc_rollup_inbox_repr.ml | 4 +- .../lib_protocol/sc_rollup_inbox_storage.ml | 6 +- .../lib_protocol/sc_rollup_wasm.ml | 2 +- .../lib_protocol/script_interpreter.ml | 127 +++++++---- .../lib_protocol/script_interpreter_defs.ml | 21 +- .../lib_protocol/script_ir_unparser.ml | 34 +-- .../lib_protocol/script_ir_unparser.mli | 34 +-- .../lib_protocol/script_typed_ir.ml | 50 ++-- .../lib_protocol/script_typed_ir.mli | 50 ++-- src/proto_alpha/lib_protocol/storage.ml | 125 ++++++++-- .../lib_protocol/storage_functors.ml | 2 + src/proto_alpha/lib_protocol/storage_sigs.ml | 81 ++++--- .../test/helpers/dummy_zk_rollup.ml | 7 +- .../lib_protocol/test/helpers/op.mli | 2 +- .../lib_protocol/ticket_accounting.ml | 10 +- .../lib_protocol/ticket_transfer.ml | 10 +- .../lib_protocol/zk_rollup_account_repr.ml | 25 +- .../lib_protocol/zk_rollup_account_repr.mli | 6 +- .../lib_protocol/zk_rollup_apply.ml | 2 +- .../lib_protocol/zk_rollup_apply.mli | 2 +- .../lib_protocol/zk_rollup_storage.ml | 4 +- 40 files changed, 659 insertions(+), 473 deletions(-) diff --git a/src/lib_protocol_environment/sigs/v8.in.ml b/src/lib_protocol_environment/sigs/v8.in.ml index 68abe98f68a35..9c5c3b5048e48 100644 --- a/src/lib_protocol_environment/sigs/v8.in.ml +++ b/src/lib_protocol_environment/sigs/v8.in.ml @@ -3,135 +3,138 @@ module type T = sig include Tezos_protocol_environment_sigs_internals.CamlinternalFormatBasics end - module Pervasives : [%sig "v8/pervasives.mli"] + module Pervasives : [%sig "v8/pervasives.mli"] [@@coq_plain_module] open Pervasives - module Either : [%sig "v8/either.mli"] + module Either : [%sig "v8/either.mli"] [@@coq_plain_module] - module String : [%sig "v8/string.mli"] + module String : [%sig "v8/string.mli"] [@@coq_plain_module] - module Char : [%sig "v8/char.mli"] + module Char : [%sig "v8/char.mli"] [@@coq_plain_module] - module Bytes : [%sig "v8/bytes.mli"] + module Bytes : [%sig "v8/bytes.mli"] [@@coq_plain_module] - module Int32 : [%sig "v8/int32.mli"] + module Int32 : [%sig "v8/int32.mli"] [@@coq_plain_module] - module Int64 : [%sig "v8/int64.mli"] + module Int64 : [%sig "v8/int64.mli"] [@@coq_plain_module] - module Format : [%sig "v8/format.mli"] + module Format : [%sig "v8/format.mli"] [@@coq_plain_module] - module Logging : [%sig "v8/logging.mli"] + module Logging : [%sig "v8/logging.mli"] [@@coq_plain_module] - module Hex : [%sig "v8/hex.mli"] + module Hex : [%sig "v8/hex.mli"] [@@coq_plain_module] - module Z : [%sig "v8/z.mli"] + module Z : [%sig "v8/z.mli"] [@@coq_plain_module] - module Q : [%sig "v8/q.mli"] + module Q : [%sig "v8/q.mli"] [@@coq_plain_module] - module Lwt : [%sig "v8/lwt.mli"] + module Lwt : [%sig "v8/lwt.mli"] [@@coq_plain_module] - module Data_encoding : [%sig "v8/data_encoding.mli"] + module Data_encoding : [%sig "v8/data_encoding.mli"] [@@coq_plain_module] - module Raw_hashes : [%sig "v8/raw_hashes.mli"] + module Raw_hashes : [%sig "v8/raw_hashes.mli"] [@@coq_plain_module] - module Compare : [%sig "v8/compare.mli"] + module Compare : [%sig "v8/compare.mli"] [@@coq_plain_module] - module Time : [%sig "v8/time.mli"] + module Time : [%sig "v8/time.mli"] [@@coq_plain_module] - module TzEndian : [%sig "v8/tzEndian.mli"] + module TzEndian : [%sig "v8/tzEndian.mli"] [@@coq_plain_module] - module Bits : [%sig "v8/bits.mli"] + module Bits : [%sig "v8/bits.mli"] [@@coq_plain_module] module Equality_witness : [%sig "v8/equality_witness.mli"] + [@@coq_plain_module] - module FallbackArray : [%sig "v8/fallbackArray.mli"] + module FallbackArray : [%sig "v8/fallbackArray.mli"] [@@coq_plain_module] - module Error_monad : [%sig "v8/error_monad.mli"] + module Error_monad : [%sig "v8/error_monad.mli"] [@@coq_plain_module] open Error_monad - module Seq : [%sig "v8/seq.mli"] + module Seq : [%sig "v8/seq.mli"] [@@coq_plain_module] - module List : [%sig "v8/list.mli"] + module List : [%sig "v8/list.mli"] [@@coq_plain_module] - module Array : [%sig "v8/array.mli"] + module Array : [%sig "v8/array.mli"] [@@coq_plain_module] - module Set : [%sig "v8/set.mli"] + module Set : [%sig "v8/set.mli"] [@@coq_plain_module] - module Map : [%sig "v8/map.mli"] + module Map : [%sig "v8/map.mli"] [@@coq_plain_module] - module Option : [%sig "v8/option.mli"] + module Option : [%sig "v8/option.mli"] [@@coq_plain_module] - module Result : [%sig "v8/result.mli"] + module Result : [%sig "v8/result.mli"] [@@coq_plain_module] - module RPC_arg : [%sig "v8/RPC_arg.mli"] + module RPC_arg : [%sig "v8/RPC_arg.mli"] [@@coq_plain_module] - module RPC_path : [%sig "v8/RPC_path.mli"] + module RPC_path : [%sig "v8/RPC_path.mli"] [@@coq_plain_module] - module RPC_query : [%sig "v8/RPC_query.mli"] + module RPC_query : [%sig "v8/RPC_query.mli"] [@@coq_plain_module] - module RPC_service : [%sig "v8/RPC_service.mli"] + module RPC_service : [%sig "v8/RPC_service.mli"] [@@coq_plain_module] - module RPC_answer : [%sig "v8/RPC_answer.mli"] + module RPC_answer : [%sig "v8/RPC_answer.mli"] [@@coq_plain_module] - module RPC_directory : [%sig "v8/RPC_directory.mli"] + module RPC_directory : [%sig "v8/RPC_directory.mli"] [@@coq_plain_module] - module Base58 : [%sig "v8/base58.mli"] + module Base58 : [%sig "v8/base58.mli"] [@@coq_plain_module] - module S : [%sig "v8/s.mli"] + module S : [%sig "v8/s.mli"] [@@coq_plain_module] - module Blake2B : [%sig "v8/blake2B.mli"] + module Blake2B : [%sig "v8/blake2B.mli"] [@@coq_plain_module] - module Bls : [%sig "v8/bls.mli"] + module Bls : [%sig "v8/bls.mli"] [@@coq_plain_module] - module Ed25519 : [%sig "v8/ed25519.mli"] + module Ed25519 : [%sig "v8/ed25519.mli"] [@@coq_plain_module] - module Secp256k1 : [%sig "v8/secp256k1.mli"] + module Secp256k1 : [%sig "v8/secp256k1.mli"] [@@coq_plain_module] - module P256 : [%sig "v8/p256.mli"] + module P256 : [%sig "v8/p256.mli"] [@@coq_plain_module] - module Chain_id : [%sig "v8/chain_id.mli"] + module Chain_id : [%sig "v8/chain_id.mli"] [@@coq_plain_module] - module Signature : [%sig "v8/signature.mli"] + module Signature : [%sig "v8/signature.mli"] [@@coq_plain_module] - module Block_hash : [%sig "v8/block_hash.mli"] + module Block_hash : [%sig "v8/block_hash.mli"] [@@coq_plain_module] - module Operation_hash : [%sig "v8/operation_hash.mli"] + module Operation_hash : [%sig "v8/operation_hash.mli"] [@@coq_plain_module] module Operation_list_hash : [%sig "v8/operation_list_hash.mli"] + [@@coq_plain_module] module Operation_list_list_hash : [%sig "v8/operation_list_list_hash.mli"] + [@@coq_plain_module] - module Protocol_hash : [%sig "v8/protocol_hash.mli"] + module Protocol_hash : [%sig "v8/protocol_hash.mli"] [@@coq_plain_module] - module Context_hash : [%sig "v8/context_hash.mli"] + module Context_hash : [%sig "v8/context_hash.mli"] [@@coq_plain_module] - module Sapling : [%sig "v8/sapling.mli"] + module Sapling : [%sig "v8/sapling.mli"] [@@coq_plain_module] - module Timelock : [%sig "v8/timelock.mli"] + module Timelock : [%sig "v8/timelock.mli"] [@@coq_plain_module] - module Vdf : [%sig "v8/vdf.mli"] + module Vdf : [%sig "v8/vdf.mli"] [@@coq_plain_module] - module Micheline : [%sig "v8/micheline.mli"] + module Micheline : [%sig "v8/micheline.mli"] [@@coq_plain_module] - module Block_header : [%sig "v8/block_header.mli"] + module Block_header : [%sig "v8/block_header.mli"] [@@coq_plain_module] - module Bounded : [%sig "v8/bounded.mli"] + module Bounded : [%sig "v8/bounded.mli"] [@@coq_plain_module] - module Fitness : [%sig "v8/fitness.mli"] + module Fitness : [%sig "v8/fitness.mli"] [@@coq_plain_module] - module Operation : [%sig "v8/operation.mli"] + module Operation : [%sig "v8/operation.mli"] [@@coq_plain_module] - module Context : [%sig "v8/context.mli"] + module Context : [%sig "v8/context.mli"] [@@coq_plain_module] - module Updater : [%sig "v8/updater.mli"] + module Updater : [%sig "v8/updater.mli"] [@@coq_plain_module] - module RPC_context : [%sig "v8/RPC_context.mli"] + module RPC_context : [%sig "v8/RPC_context.mli"] [@@coq_plain_module] - module Wasm_2_0_0 : [%sig "v8/wasm_2_0_0.mli"] + module Wasm_2_0_0 : [%sig "v8/wasm_2_0_0.mli"] [@@coq_plain_module] - module Plonk : [%sig "v8/plonk.mli"] + module Plonk : [%sig "v8/plonk.mli"] [@@coq_plain_module] - module Dal : [%sig "v8/dal.mli"] + module Dal : [%sig "v8/dal.mli"] [@@coq_plain_module] end diff --git a/src/lib_protocol_environment/sigs/v8.ml b/src/lib_protocol_environment/sigs/v8.ml index b1f5fe4171ef2..e4ded7cbd233d 100644 --- a/src/lib_protocol_environment/sigs/v8.ml +++ b/src/lib_protocol_environment/sigs/v8.ml @@ -492,7 +492,7 @@ val ( ^^ ) : *) end # 6 "v8.in.ml" - + [@@coq_plain_module] open Pervasives @@ -574,7 +574,7 @@ val compare : [Left _] values are smaller than [Right _] values. *) end # 10 "v8.in.ml" - + [@@coq_plain_module] module String : sig # 1 "v8/string.mli" @@ -822,7 +822,7 @@ val split_on_char: char -> string -> string list *) end # 12 "v8.in.ml" - + [@@coq_plain_module] module Char : sig # 1 "v8/char.mli" @@ -882,7 +882,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 14 "v8.in.ml" - + [@@coq_plain_module] module Bytes : sig # 1 "v8/bytes.mli" @@ -1204,7 +1204,7 @@ val shift_left : bytes -> int -> bytes val shift_right : bytes -> int -> bytes end # 16 "v8.in.ml" - + [@@coq_plain_module] module Int32 : sig # 1 "v8/int32.mli" @@ -1355,7 +1355,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 18 "v8.in.ml" - + [@@coq_plain_module] module Int64 : sig # 1 "v8/int64.mli" @@ -1514,7 +1514,7 @@ val equal: t -> t -> bool @since 4.03.0 *) end # 20 "v8.in.ml" - + [@@coq_plain_module] module Format : sig # 1 "v8/format.mli" @@ -2278,7 +2278,7 @@ val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b *) end # 22 "v8.in.ml" - + [@@coq_plain_module] module Logging : sig # 1 "v8/logging.mli" @@ -2328,7 +2328,7 @@ val log : level -> ('a, Format.formatter, unit, unit) format4 -> 'a val log_string : level -> string -> unit end # 24 "v8.in.ml" - + [@@coq_plain_module] module Hex : sig # 1 "v8/hex.mli" @@ -2416,7 +2416,7 @@ val show : t -> string a string. *) end # 26 "v8.in.ml" - + [@@coq_plain_module] module Z : sig # 1 "v8/z.mli" @@ -2890,7 +2890,7 @@ external of_bits: string -> t = "ml_z_of_bits" *) end # 28 "v8.in.ml" - + [@@coq_plain_module] module Q : sig # 1 "v8/q.mli" @@ -3162,7 +3162,7 @@ val (<>): t -> t -> bool (** [a <> b] is equivalent to [not (equal a b)]. *) end # 30 "v8.in.ml" - + [@@coq_plain_module] module Lwt : sig # 1 "v8/lwt.mli" @@ -3474,7 +3474,7 @@ val return_error : 'e -> ((_, 'e) result) t @since Lwt 2.6.0 *) end # 32 "v8.in.ml" - + [@@coq_plain_module] module Data_encoding : sig # 1 "v8/data_encoding.mli" @@ -5249,7 +5249,7 @@ module Binary : sig end end # 34 "v8.in.ml" - + [@@coq_plain_module] module Raw_hashes : sig # 1 "v8/raw_hashes.mli" @@ -5291,7 +5291,7 @@ val sha3_256 : bytes -> bytes val sha3_512 : bytes -> bytes end # 36 "v8.in.ml" - + [@@coq_plain_module] module Compare : sig # 1 "v8/compare.mli" @@ -5572,7 +5572,7 @@ let compare (foo_a, bar_a) (foo_b, bar_b) = val or_else : int -> (unit -> int) -> int end # 38 "v8.in.ml" - + [@@coq_plain_module] module Time : sig # 1 "v8/time.mli" @@ -5626,7 +5626,7 @@ val rfc_encoding : t Data_encoding.t val pp_hum : Format.formatter -> t -> unit end # 40 "v8.in.ml" - + [@@coq_plain_module] module TzEndian : sig # 1 "v8/tzEndian.mli" @@ -5692,7 +5692,7 @@ val get_uint16_string : string -> int -> int val set_uint16 : bytes -> int -> int -> unit end # 42 "v8.in.ml" - + [@@coq_plain_module] module Bits : sig # 1 "v8/bits.mli" @@ -5729,7 +5729,7 @@ end val numbits : int -> int end # 44 "v8.in.ml" - + [@@coq_plain_module] module Equality_witness : sig # 1 "v8/equality_witness.mli" @@ -5798,6 +5798,7 @@ val hash : 'a t -> int end # 46 "v8.in.ml" + [@@coq_plain_module] module FallbackArray : sig # 1 "v8/fallbackArray.mli" @@ -5886,8 +5887,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 -# 48 "v8.in.ml" - +# 49 "v8.in.ml" + [@@coq_plain_module] module Error_monad : sig # 1 "v8/error_monad.mli" @@ -6320,8 +6321,8 @@ module Lwt_option_syntax : sig val both : 'a option Lwt.t -> 'b option Lwt.t -> ('a * 'b) option Lwt.t end end -# 50 "v8.in.ml" - +# 51 "v8.in.ml" + [@@coq_plain_module] open Error_monad @@ -6447,8 +6448,8 @@ val iter_ep : them is. *) val iter_p : ('a -> unit Lwt.t) -> 'a t -> unit Lwt.t end -# 54 "v8.in.ml" - +# 55 "v8.in.ml" + [@@coq_plain_module] module List : sig # 1 "v8/list.mli" @@ -7793,8 +7794,8 @@ val exists_ep : 'a list -> (bool, 'error Error_monad.trace) result Lwt.t end -# 56 "v8.in.ml" - +# 57 "v8.in.ml" + [@@coq_plain_module] module Array : sig # 1 "v8/array.mli" @@ -7903,8 +7904,8 @@ val fast_sort : [`You_cannot_sort_arrays_in_the_protocol] module Floatarray : sig end end -# 58 "v8.in.ml" - +# 59 "v8.in.ml" + [@@coq_plain_module] module Set : sig # 1 "v8/set.mli" @@ -8052,8 +8053,8 @@ end module Make (Ord : Compare.COMPARABLE) : S with type elt = Ord.t end -# 60 "v8.in.ml" - +# 61 "v8.in.ml" + [@@coq_plain_module] module Map : sig # 1 "v8/map.mli" @@ -8221,8 +8222,8 @@ end module Make (Ord : Compare.COMPARABLE) : S with type key = Ord.t end -# 62 "v8.in.ml" - +# 63 "v8.in.ml" + [@@coq_plain_module] module Option : sig # 1 "v8/option.mli" @@ -8369,8 +8370,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 -# 64 "v8.in.ml" - +# 65 "v8.in.ml" + [@@coq_plain_module] module Result : sig # 1 "v8/result.mli" @@ -8535,8 +8536,8 @@ val catch_f : val catch_s : ?catch_only:(exn -> bool) -> (unit -> 'a Lwt.t) -> ('a, exn) result Lwt.t end -# 66 "v8.in.ml" - +# 67 "v8.in.ml" + [@@coq_plain_module] module RPC_arg : sig # 1 "v8/RPC_arg.mli" @@ -8605,8 +8606,8 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val eq : 'a arg -> 'b arg -> ('a, 'b) eq option end -# 68 "v8.in.ml" - +# 69 "v8.in.ml" + [@@coq_plain_module] module RPC_path : sig # 1 "v8/RPC_path.mli" @@ -8661,8 +8662,8 @@ val add_final_args : val ( /:* ) : ('prefix, 'params) path -> 'a RPC_arg.t -> ('prefix, 'params * 'a list) path end -# 70 "v8.in.ml" - +# 71 "v8.in.ml" + [@@coq_plain_module] module RPC_query : sig # 1 "v8/RPC_query.mli" @@ -8733,8 +8734,8 @@ exception Invalid of string val parse : 'a query -> untyped -> 'a end -# 72 "v8.in.ml" - +# 73 "v8.in.ml" + [@@coq_plain_module] module RPC_service : sig # 1 "v8/RPC_service.mli" @@ -8810,8 +8811,8 @@ val put_service : ('prefix, 'params) RPC_path.t -> ([`PUT], 'prefix, 'params, 'query, 'input, 'output) service end -# 74 "v8.in.ml" - +# 75 "v8.in.ml" + [@@coq_plain_module] module RPC_answer : sig # 1 "v8/RPC_answer.mli" @@ -8871,8 +8872,8 @@ val not_found : 'o t Lwt.t val fail : error list -> 'a t Lwt.t end -# 76 "v8.in.ml" - +# 77 "v8.in.ml" + [@@coq_plain_module] module RPC_directory : sig # 1 "v8/RPC_directory.mli" @@ -9141,8 +9142,8 @@ val register_dynamic_directory : ('a -> 'a directory Lwt.t) -> 'prefix directory end -# 78 "v8.in.ml" - +# 79 "v8.in.ml" + [@@coq_plain_module] module Base58 : sig # 1 "v8/base58.mli" @@ -9206,8 +9207,8 @@ val check_encoded_prefix : 'a encoding -> string -> int -> unit not start with a registered prefix. *) val decode : string -> data option end -# 80 "v8.in.ml" - +# 81 "v8.in.ml" + [@@coq_plain_module] module S : sig # 1 "v8/s.mli" @@ -9568,8 +9569,8 @@ module type CURVE = sig val mul : t -> Scalar.t -> t end end -# 82 "v8.in.ml" - +# 83 "v8.in.ml" + [@@coq_plain_module] module Blake2B : sig # 1 "v8/blake2B.mli" @@ -9633,8 +9634,8 @@ end module Make (Register : Register) (Name : PrefixedName) : S.HASH end -# 84 "v8.in.ml" - +# 85 "v8.in.ml" + [@@coq_plain_module] module Bls : sig # 1 "v8/bls.mli" @@ -9679,8 +9680,8 @@ module Primitive : sig val pairing_check : (G1.t * G2.t) list -> bool end end -# 86 "v8.in.ml" - +# 87 "v8.in.ml" + [@@coq_plain_module] module Ed25519 : sig # 1 "v8/ed25519.mli" @@ -9713,8 +9714,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 88 "v8.in.ml" - +# 89 "v8.in.ml" + [@@coq_plain_module] module Secp256k1 : sig # 1 "v8/secp256k1.mli" @@ -9747,8 +9748,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 90 "v8.in.ml" - +# 91 "v8.in.ml" + [@@coq_plain_module] module P256 : sig # 1 "v8/p256.mli" @@ -9781,8 +9782,8 @@ end include S.SIGNATURE with type watermark := bytes end -# 92 "v8.in.ml" - +# 93 "v8.in.ml" + [@@coq_plain_module] module Chain_id : sig # 1 "v8/chain_id.mli" @@ -9813,8 +9814,8 @@ end include S.HASH end -# 94 "v8.in.ml" - +# 95 "v8.in.ml" + [@@coq_plain_module] module Signature : sig # 1 "v8/signature.mli" @@ -9865,8 +9866,8 @@ include and type Public_key.t = public_key and type watermark := watermark end -# 96 "v8.in.ml" - +# 97 "v8.in.ml" + [@@coq_plain_module] module Block_hash : sig # 1 "v8/block_hash.mli" @@ -9898,8 +9899,8 @@ end (** Blocks hashes / IDs. *) include S.HASH end -# 98 "v8.in.ml" - +# 99 "v8.in.ml" + [@@coq_plain_module] module Operation_hash : sig # 1 "v8/operation_hash.mli" @@ -9931,8 +9932,8 @@ end (** Operations hashes / IDs. *) include S.HASH end -# 100 "v8.in.ml" - +# 101 "v8.in.ml" + [@@coq_plain_module] module Operation_list_hash : sig # 1 "v8/operation_list_hash.mli" @@ -9964,8 +9965,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_hash.t end -# 102 "v8.in.ml" +# 103 "v8.in.ml" + [@@coq_plain_module] module Operation_list_list_hash : sig # 1 "v8/operation_list_list_hash.mli" @@ -9997,8 +9999,9 @@ end (** Blocks hashes / IDs. *) include S.MERKLE_TREE with type elt = Operation_list_hash.t end -# 104 "v8.in.ml" +# 106 "v8.in.ml" + [@@coq_plain_module] module Protocol_hash : sig # 1 "v8/protocol_hash.mli" @@ -10030,8 +10033,8 @@ end (** Protocol hashes / IDs. *) include S.HASH end -# 106 "v8.in.ml" - +# 109 "v8.in.ml" + [@@coq_plain_module] module Context_hash : sig # 1 "v8/context_hash.mli" @@ -10083,8 +10086,8 @@ end type version = Version.t end -# 108 "v8.in.ml" - +# 111 "v8.in.ml" + [@@coq_plain_module] module Sapling : sig # 1 "v8/sapling.mli" @@ -10231,8 +10234,8 @@ module Verification : sig val final_check : t -> UTXO.transaction -> string -> bool end end -# 110 "v8.in.ml" - +# 113 "v8.in.ml" + [@@coq_plain_module] module Timelock : sig # 1 "v8/timelock.mli" @@ -10290,8 +10293,8 @@ val open_chest : chest -> chest_key -> time:int -> opening_result Used for gas accounting*) val get_plaintext_size : chest -> int end -# 112 "v8.in.ml" - +# 115 "v8.in.ml" + [@@coq_plain_module] module Vdf : sig # 1 "v8/vdf.mli" @@ -10378,8 +10381,8 @@ val prove : discriminant -> challenge -> difficulty -> result * proof @raise Invalid_argument when inputs are invalid *) val verify : discriminant -> challenge -> difficulty -> result -> proof -> bool end -# 114 "v8.in.ml" - +# 117 "v8.in.ml" + [@@coq_plain_module] module Micheline : sig # 1 "v8/micheline.mli" @@ -10438,8 +10441,8 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical end -# 116 "v8.in.ml" - +# 119 "v8.in.ml" + [@@coq_plain_module] module Block_header : sig # 1 "v8/block_header.mli" @@ -10495,8 +10498,8 @@ type t = {shell : shell_header; protocol_data : bytes} include S.HASHABLE with type t := t and type hash := Block_hash.t end -# 118 "v8.in.ml" - +# 121 "v8.in.ml" + [@@coq_plain_module] module Bounded : sig # 1 "v8/bounded.mli" @@ -10644,8 +10647,8 @@ module Int8 (B : BOUNDS with type ocaml_type := int) : module Uint8 (B : BOUNDS with type ocaml_type := int) : S with type ocaml_type := int end -# 120 "v8.in.ml" - +# 123 "v8.in.ml" + [@@coq_plain_module] module Fitness : sig # 1 "v8/fitness.mli" @@ -10678,8 +10681,8 @@ end compared in a lexicographical order (longer list are greater). *) include S.T with type t = bytes list end -# 122 "v8.in.ml" - +# 125 "v8.in.ml" + [@@coq_plain_module] module Operation : sig # 1 "v8/operation.mli" @@ -10722,8 +10725,8 @@ type t = {shell : shell_header; proto : bytes} include S.HASHABLE with type t := t and type hash := Operation_hash.t end -# 124 "v8.in.ml" - +# 127 "v8.in.ml" + [@@coq_plain_module] module Context : sig # 1 "v8/context.mli" @@ -11359,8 +11362,8 @@ module Cache : and type key = cache_key and type value = cache_value end -# 126 "v8.in.ml" - +# 129 "v8.in.ml" + [@@coq_plain_module] module Updater : sig # 1 "v8/updater.mli" @@ -11886,8 +11889,8 @@ end not complete until [init] in invoked. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t end -# 128 "v8.in.ml" - +# 131 "v8.in.ml" + [@@coq_plain_module] module RPC_context : sig # 1 "v8/RPC_context.mli" @@ -12041,8 +12044,8 @@ val make_opt_call3 : 'i -> 'o option shell_tzresult Lwt.t end -# 130 "v8.in.ml" - +# 133 "v8.in.ml" + [@@coq_plain_module] module Wasm_2_0_0 : sig # 1 "v8/wasm_2_0_0.mli" @@ -12112,8 +12115,8 @@ module Make (Tree : Context.TREE with type key = string list and type value = bytes) : S with type tree := Tree.tree end -# 132 "v8.in.ml" - +# 135 "v8.in.ml" + [@@coq_plain_module] module Plonk : sig # 1 "v8/plonk.mli" @@ -12180,8 +12183,8 @@ val verify_multi_circuits : proof -> bool end -# 134 "v8.in.ml" - +# 137 "v8.in.ml" + [@@coq_plain_module] module Dal : sig # 1 "v8/dal.mli" @@ -12299,6 +12302,6 @@ val verify_page : page_proof -> (bool, [> `Segment_index_out_of_range | `Page_length_mismatch]) Result.t end -# 136 "v8.in.ml" - +# 139 "v8.in.ml" + [@@coq_plain_module] end diff --git a/src/proto_alpha/lib_plugin/script_interpreter_logging.ml b/src/proto_alpha/lib_plugin/script_interpreter_logging.ml index d05cb3b660827..bd4ce44a352e8 100644 --- a/src/proto_alpha/lib_plugin/script_interpreter_logging.ml +++ b/src/proto_alpha/lib_plugin/script_interpreter_logging.ml @@ -2277,4 +2277,10 @@ let make (module Base : Logger_base) = let module Logger = Logger (Base) in let open Logger in let open Base in - {log_interp; get_log; log_kinstr; klog; ilog} + { + log_interp; + get_log; + log_kinstr = Log_kinstr log_kinstr; + klog = Klog klog; + ilog = Ilog ilog; + } diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index f0b2360890c1a..2ae2861e72074 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -122,10 +122,6 @@ module Dal = struct index : Dal_slot_repr.Index.t; } - module Page = struct - include Dal_slot_repr.Page - end - module Slot = struct include Dal_slot_repr include Dal_slot_storage diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 6be83e3ce89cf..c923feb0d2181 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2397,15 +2397,18 @@ module Zk_rollup : sig val encoding : t Data_encoding.t end + [@@coq_plain_module] (** This module re-exports definitions from {!Zk_rollup_account_repr}. *) module Account : sig module SMap : Map.S with type key = string + type circuit_info = Public | Private | Fee + type static = { public_parameters : Plonk.public_parameters; state_length : int; - circuits_info : [`Public | `Private | `Fee] SMap.t; + circuits_info : circuit_info SMap.t; nb_ops : int; } @@ -2491,6 +2494,7 @@ module Zk_rollup : sig val encoding : t Data_encoding.t end + [@@coq_plain_module] type pending_list = | Empty of {next_index : int64} @@ -2947,7 +2951,10 @@ module Dal : sig type shard_index = int - module Shard_map : Map.S with type key = shard_index + module Shard_map : + Map.S + with type key = shard_index + and type 'a t = 'a Dal_attestation_repr.Shard_map.t val encoding : t Data_encoding.t @@ -2964,7 +2971,7 @@ module Dal : sig val record_available_shards : context -> t -> int list -> context - type committee = { + type committee = Raw_context.Dal.committee = { pkh_to_shards : (shard_index * int) Signature.Public_key_hash.Map.t; shard_to_pkh : Signature.Public_key_hash.t Shard_map.t; } @@ -4678,7 +4685,7 @@ and _ manager_operation = -> Kind.sc_rollup_recover_bond manager_operation | Zk_rollup_origination : { public_parameters : Plonk.public_parameters; - circuits_info : [`Public | `Private | `Fee] Zk_rollup.Account.SMap.t; + circuits_info : Zk_rollup.Account.circuit_info Zk_rollup.Account.SMap.t; init_state : Zk_rollup.State.t; nb_ops : int; } diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 9188970eb4f4d..c541a9ff090fe 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -840,7 +840,7 @@ module Manager_result = struct | Successful_manager_result (Zk_rollup_update_result _ as op) -> Some op | _ -> None) ~kind:Kind.Zk_rollup_update_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Zk_rollup_update_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) diff --git a/src/proto_alpha/lib_protocol/dal_slot_repr.ml b/src/proto_alpha/lib_protocol/dal_slot_repr.ml index e6f82839909cf..88a37f3a28891 100644 --- a/src/proto_alpha/lib_protocol/dal_slot_repr.ml +++ b/src/proto_alpha/lib_protocol/dal_slot_repr.ml @@ -127,7 +127,7 @@ module Header = struct Format.fprintf fmt "id:(%a), commitment: %a" pp_id id Commitment.pp c end -module Slot_index = Index +module Dal_slot_repr_Index = Index module Page = struct type content = Bytes.t @@ -163,7 +163,7 @@ module Page = struct {slot_id = {published_level; index}; page_index}) (obj3 (req "published_level" Raw_level_repr.encoding) - (req "slot_index" Slot_index.encoding) + (req "slot_index" Dal_slot_repr_Index.encoding) (req "page_index" Index.encoding)) let equal {slot_id; page_index} p = @@ -180,7 +180,7 @@ module Page = struct "(published_level: %a, slot_index: %a, page_index: %a)" Raw_level_repr.pp published_level - Slot_index.pp + Dal_slot_repr_Index.pp index Index.pp page_index @@ -246,7 +246,7 @@ module History = struct end module Content_prefix = struct - let (_prefix : string) = "dash1" + let _prefix = "dash1" (* 32 *) let b58check_prefix = "\002\224\072\094\219" (* dash1(55) *) @@ -264,7 +264,7 @@ module History = struct (* Pointers of the skip lists are used to encode the content and the backpointers. *) module Pointer_prefix = struct - let (_prefix : string) = "dask1" + let _prefix = "dask1" (* 32 *) let b58check_prefix = "\002\224\072\115\035" (* dask1(55) *) @@ -700,8 +700,8 @@ module History = struct let proof_error reason = error @@ dal_proof_error reason - let check_page_proof dal_params proof data ({Page.page_index; _} as pid) - commitment = + let[@coq_axiom_with_reason "polymorphic variant"] check_page_proof + dal_params proof data ({Page.page_index; _} as pid) commitment = let open Result_syntax in let* dal = match Dal.make dal_params with @@ -813,7 +813,8 @@ module History = struct (* Given a starting cell [snapshot] and a (final) [target], this function checks that the provided [inc_proof] encodes a minimal path from [snapshot] to [target]. *) - let verify_inclusion_proof inc_proof ~src:snapshot ~dest:target = + let[@coq_axiom_with_reason "open of a functor application"] verify_inclusion_proof + inc_proof ~src:snapshot ~dest:target = let assoc = List.map (fun c -> (hash_skip_list_cell c, c)) inc_proof in let path = List.split assoc |> fst in let deref = diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas_costs.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas_costs.ml index 8f741bdefb2b5..bdade5644a659 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas_costs.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas_costs.ml @@ -27,7 +27,6 @@ (*****************************************************************************) include Michelson_v1_gas_costs_generated -module S = Saturation_repr (* This file contains functions saved from the original michelson_v1_gas_costs.ml. diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 9ee5d17256326..f544cc7a5d1fc 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -478,7 +478,8 @@ and _ manager_operation = -> Kind.sc_rollup_recover_bond manager_operation | Zk_rollup_origination : { public_parameters : Plonk.public_parameters; - circuits_info : [`Public | `Private | `Fee] Zk_rollup_account_repr.SMap.t; + circuits_info : + Zk_rollup_account_repr.circuit_info Zk_rollup_account_repr.SMap.t; init_state : Zk_rollup_state_repr.t; nb_ops : int; } @@ -1132,7 +1133,7 @@ module Encoding = struct (function | Manager (Zk_rollup_update _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Zk_rollup_update {zk_rollup; update} -> (zk_rollup, update)); inj = (fun (zk_rollup, update) -> Zk_rollup_update {zk_rollup; update}); diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index f90342b9db044..2e0c5c04664e9 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -567,7 +567,8 @@ and _ manager_operation = -> Kind.sc_rollup_recover_bond manager_operation | Zk_rollup_origination : { public_parameters : Plonk.public_parameters; - circuits_info : [`Public | `Private | `Fee] Zk_rollup_account_repr.SMap.t; + circuits_info : + Zk_rollup_account_repr.circuit_info Zk_rollup_account_repr.SMap.t; (** Circuit names, alongside a tag indicating its kind. *) init_state : Zk_rollup_state_repr.t; nb_ops : int; diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 96c8b4803286f..0038b699b71c0 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1265,8 +1265,6 @@ let non_consensus_operations ctxt = List.rev (non_consensus_operations_rev ctxt) let record_dictator_proposal_seen ctxt = update_dictator_proposal_seen ctxt true -let dictator_proposal_seen ctxt = dictator_proposal_seen ctxt - let init_sampler_for_cycle ctxt cycle seed state = let map = sampler_state ctxt in if Cycle_repr.Map.mem cycle map then error (Sampler_already_set cycle) @@ -1602,7 +1600,7 @@ module Dal = struct Misc.(slot_index --> (slot_index + (power - 1))); } in - let rec compute_power index committee = + let[@coq_struct "index_value"] rec compute_power index committee = if Compare.Int.(index < 0) then return committee else let shard_index = index mod consensus_committee_size in @@ -1640,14 +1638,16 @@ module Dal = struct {ctxt with back = {ctxt.back with dal_committee = committee}} let shards_of_attestor ctxt ~attestor:pkh = - let rec make acc (initial_shard_index, power) = + let[@coq_struct "power"] rec make acc initial_shard_index power = if Compare.Int.(power <= 0) then List.rev acc - else make (initial_shard_index :: acc) (initial_shard_index + 1, power - 1) + else + make (initial_shard_index :: acc) (initial_shard_index + 1) (power - 1) in Signature.Public_key_hash.Map.find_opt pkh ctxt.back.dal_committee.pkh_to_shards - |> Option.map (fun pre_shards -> make [] pre_shards) + |> Option.map (fun (initial_shard_index, power) -> + make [] initial_shard_index power) end (* The type for relative context accesses instead from the root. In order for @@ -1678,19 +1678,10 @@ let with_local_context ctxt key f = update_unlimited_operation_gas ctxt local_ctxt.unlimited_operation_gas |> fun ctxt -> ok (ctxt, res) -module Local_context : sig - include - Raw_context_intf.VIEW - with type t = local_context - and type key := key - and type value := value - and type tree := tree - - val consume_gas : - local_context -> Gas_limit_repr.cost -> local_context tzresult - - val absolute_key : local_context -> key -> key -end = struct +module Local_context : + Raw_context_intf.S_Local_context + with type local_context := local_context + and type tree := tree = struct type t = local_context let consume_gas local cost = diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index e372fbae00e28..30b59e479686c 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -66,6 +66,12 @@ val storage_error : storage_error -> 'a tzresult (** {1 Abstract Context} *) +type dal_committee = { + pkh_to_shards : + (Dal_attestation_repr.shard_index * int) Signature.Public_key_hash.Map.t; + shard_to_pkh : Signature.Public_key_hash.t Dal_attestation_repr.Shard_map.t; +} + (** Abstract view of the context. Includes a handle to the functional key-value database ({!Context.t}) along with some in-memory values (gas, etc.). *) @@ -448,7 +454,7 @@ module Dal : sig - Given an attestor, all its shards assignement are contiguous *) - type committee = { + type committee = dal_committee = { pkh_to_shards : (Dal_attestation_repr.shard_index * int) Signature.Public_key_hash.Map.t; shard_to_pkh : Signature.Public_key_hash.t Dal_attestation_repr.Shard_map.t; diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index 36eced8c398b3..7e72b3635e9b5 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml @@ -458,6 +458,33 @@ module type PROOF = sig } end +module type S_Local_context = sig + type local_context + + type tree + + type key := string list + + type value := bytes + + include + VIEW + with type t = local_context + and type tree := tree + and type key := key + and type value := value + + (** Internally used in {!Storage_functors} to consume gas from + within a view. May raise {!Block_quota_exceeded} or + {!Operation_quota_exceeded}. *) + val consume_gas : + local_context -> Gas_limit_repr.cost -> local_context tzresult + + (** Internally used in {!Storage_functors} to retrieve the full key of a + partial key relative to the [local_context]. *) + val absolute_key : local_context -> key -> key +end + module type T = sig (** The type for root contexts. *) type root @@ -583,22 +610,8 @@ module type T = sig (** [Local_context] provides functions for local access from a specific directory. *) - module Local_context : sig - include - VIEW - with type t = local_context - and type tree := tree - and type key := key - and type value := value - - (** Internally used in {!Storage_functors} to consume gas from - within a view. May raise {!Block_quota_exceeded} or - {!Operation_quota_exceeded}. *) - val consume_gas : - local_context -> Gas_limit_repr.cost -> local_context tzresult - - (** Internally used in {!Storage_functors} to retrieve the full key of a - partial key relative to the [local_context]. *) - val absolute_key : local_context -> key -> key - end + module Local_context : + S_Local_context + with type local_context := local_context + and type tree := tree end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_PVM_sig.ml b/src/proto_alpha/lib_protocol/sc_rollup_PVM_sig.ml index 8b8b3a6232192..3c0d48eeb8319 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_PVM_sig.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_PVM_sig.ml @@ -205,25 +205,23 @@ module Input_hash = module Reveal_hash = struct (* Reserve the first byte in the encoding to support multi-versioning in the future. *) - module V0 = struct - include - Blake2B.Make - (Base58) - (struct - let name = "Sc_rollup_reveal_data_hash" + module V0 = + Blake2B.Make + (Base58) + (struct + let name = "Sc_rollup_reveal_data_hash" - let title = "A smart contract rollup reveal hash" + let title = "A smart contract rollup reveal hash" - let b58check_prefix = - "\017\144\121\209\203" (* "scrrh1(54)" decoded from Base58. *) + let b58check_prefix = + "\017\144\121\209\203" (* "scrrh1(54)" decoded from Base58. *) - let size = Some 31 - end) + let size = Some 31 + end) - let () = Base58.check_encoded_prefix b58check_encoding "scrrh1" 54 - end + let () = Base58.check_encoded_prefix V0.b58check_encoding "scrrh1" 54 - include V0 + include V0 [@@coq_include_without "encoding"] let encoding = let open Data_encoding in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index e2e6a414edc66..cf88d12bc78a1 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -1410,7 +1410,8 @@ module Make (Context : P) : let eval state = state_of (ticked eval_step) state - let step_transition input_given state = + let[@coq_axiom_with_reason "unresolved implicit arguments"] step_transition + input_given state = let open Lwt_syntax in let* request = is_input_state state in let error msg = state_of (internal_error msg) state in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml index e40e7edc0b2d3..cea6d837399f7 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_dissection_chunk_repr.ml @@ -85,8 +85,8 @@ let pp ppf {state_hash; tick} = Sc_rollup_tick_repr.pp tick -let default_check ~default_number_of_sections ~start_chunk ~stop_chunk - dissection = +let[@coq_axiom_with_reason "complex recursion"] default_check + ~default_number_of_sections ~start_chunk ~stop_chunk dissection = let open Result_syntax in let len = Z.of_int @@ List.length dissection in let dist = Sc_rollup_tick_repr.distance start_chunk.tick stop_chunk.tick in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml index c2632e51a926d..c8f4a6bad4158 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml @@ -127,7 +127,13 @@ module History = struct let _sig_NAME = () end) (struct - include Hash + type t = Hash.t + + let compare = Hash.compare + + let pp = Hash.pp + + let encoding = Hash.encoding let _sig_KEY = () end) @@ -213,7 +219,9 @@ let verify_proof inclusion_proof = | [] -> error (Merkelized_payload_hashes_proof_error "inclusion proof is empty") in - let rec aux (hash_map, ptr_list) = function + let rec aux hash_map_ptr_list l = + let hash_map, ptr_list = hash_map_ptr_list in + match l with | [] -> error (Merkelized_payload_hashes_proof_error "inclusion proof is empty") | [target] -> diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.mli index c204bf0f6f45d..dbe76bf4ed29f 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.mli @@ -24,7 +24,7 @@ type error += Merkelized_payload_hashes_proof_error of string -module Hash : S.HASH +module Hash : S.HASH [@@coq_plain_module] (** A type representing the head of a merkelized list of {!Sc_rollup_inbox_message_repr.serialized} message. It contains the hash of diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli index 4a0914557d786..4f60a459cc337 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli @@ -88,7 +88,7 @@ val unsafe_of_string : string -> serialized val unsafe_to_string : serialized -> string -module Hash : S.HASH +module Hash : S.HASH [@@coq_plain_module] (** [hash_serialized_message payload] is the hash of [payload]. It is used by {!Sc_rollup_inbox_merkelized_payload_hashes_repr.t}. *) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index a7c3c81c81094..68d3836968ccf 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -788,7 +788,9 @@ let produce_level_tree_proof get_level_tree_history head_cell_hash ~index = else return {proof; payload = None} | None -> tzfail (Inbox_proof_error "could not produce a valid proof.") -let verify_inclusion_proof inclusion_proof snapshot_history_proof = +let[@coq_axiom_with_reason "implict types"] [@coq_struct "fixpoint"] verify_inclusion_proof + (inclusion_proof : inclusion_proof) (snapshot_history_proof : history_proof) + : history_proof tzresult = let open Result_syntax in let rec aux (hash_map, ptr_list) = function | [] -> error (Inbox_proof_error "inclusion proof is empty") diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml index 7b84c14893de3..634004e7eabc8 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml @@ -53,7 +53,7 @@ let _assert_inbox_nb_messages_in_commitment_period ctxt inbox extra_messages = Compare.Int64.(nb_messages_in_commitment_period > limit) Sc_rollup_max_number_of_messages_reached_for_commitment_period -let add_messages ctxt messages = +let add_messages_aux ctxt messages = let {Level_repr.level; _} = Raw_context.current_level ctxt in let open Lwt_result_syntax in let open Raw_context in @@ -149,12 +149,12 @@ let serialize_internal_message ctxt internal_message = let add_external_messages ctxt external_messages = let open Lwt_result_syntax in let*? ctxt, messages = serialize_external_messages ctxt external_messages in - add_messages ctxt messages + add_messages_aux ctxt messages let add_internal_message ctxt internal_message = let open Lwt_result_syntax in let*? message, ctxt = serialize_internal_message ctxt internal_message in - add_messages ctxt [message] + add_messages_aux ctxt [message] let add_deposit ctxt ~payload ~sender ~source ~destination = let internal_message : Sc_rollup_inbox_message_repr.internal_inbox_message = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index cc5fd490ce1f6..2f4310f4dbfb9 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -323,7 +323,7 @@ module V2_0_0 = struct Raw_level_repr.to_int32_non_negative outbox_level in let open Lwt_syntax in - let rec aux outbox message_index = + let[@coq_struct "message_index"] rec aux outbox message_index = let output = Wasm_2_0_0.{outbox_level = outbox_level_int32; message_index} in diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 8ada8db595f06..88291491ab24f 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -330,7 +330,8 @@ module Raw = struct | Some gas -> ( match ks0 with | KLog (ks, sty, logger) -> - (logger.klog [@ocaml.tailcall]) logger g gas sty ks0 ks accu stack + let (Klog klog) = logger.klog in + klog 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') -> @@ -475,21 +476,24 @@ module Raw = struct and 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 + let x = accu in + let y, stack = stack in match Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> tzfail (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 = fun logger g gas loc k ks accu stack -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in match Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> tzfail (Overflow (loc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack and ilsl_bytes : type a b c d e f. (a, b, c, d, e, f) ilsl_bytes_type = fun logger g gas loc k ks accu stack -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in match Script_bytes.bytes_lsl x y with | None -> get_log logger >>=? fun log -> tzfail (Overflow (loc, log)) | Some res -> (step [@ocaml.tailcall]) g gas k ks res stack @@ -507,12 +511,15 @@ module Raw = struct and 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 arg = accu in + let code, stack = stack in let log_code b = let body = match logger with | None -> b.kinstr - | Some logger -> logger.log_kinstr logger b.kbef b.kinstr + | Some logger -> + let (Log_kinstr log_kinstr) = logger.log_kinstr in + log_kinstr logger b.kbef b.kinstr in let ks = instrument @@ KReturn (stack, cont_sty, KCons (k, ks)) in (body, ks) @@ -633,16 +640,8 @@ module Raw = struct | Some gas -> ( match i with | ILog (_, sty, event, logger, k) -> - (logger.ilog [@ocaml.tailcall]) - logger - event - sty - g - gas - k - ks - accu - stack + let (Ilog ilog) = logger.ilog in + ilog logger event sty g gas k ks accu stack | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack (* stack ops *) | IDrop (_, k) -> @@ -877,7 +876,8 @@ module Raw = struct 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 + 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 @@ -910,7 +910,8 @@ module Raw = struct 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 + 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 @@ -925,19 +926,23 @@ module Raw = struct (step [@ocaml.tailcall]) g gas k ks result stack | ILsl_bytes (loc, k) -> ilsl_bytes None g gas loc k ks accu stack | ILsr_bytes (_, k) -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in let res = Script_bytes.bytes_lsr x y in (step [@ocaml.tailcall]) g gas k ks res stack | IOr_bytes (_, k) -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in let res = Script_bytes.bytes_or x y in (step [@ocaml.tailcall]) g gas k ks res stack | IAnd_bytes (_, k) -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in let res = Script_bytes.bytes_and x y in (step [@ocaml.tailcall]) g gas k ks res stack | IXor_bytes (_, k) -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in let res = Script_bytes.bytes_xor x y in (step [@ocaml.tailcall]) g gas k ks res stack | INot_bytes (_, k) -> @@ -997,27 +1002,33 @@ module Raw = struct 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 + 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 + 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 + 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 + 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 + 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 + 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 @@ -1034,7 +1045,8 @@ module Raw = struct in (step [@ocaml.tailcall]) g gas k ks result stack | IEdiv_tez (_, k) -> - let x = accu and y, stack = stack in + 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 = @@ -1050,29 +1062,35 @@ module Raw = struct in (step [@ocaml.tailcall]) g gas k ks result stack | IEdiv_int (_, k) -> - let x = accu and y, stack = stack in + 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 + 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) -> - let x = accu and y, stack = stack in + 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 + 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 + 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 + 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) -> @@ -1262,7 +1280,8 @@ module Raw = struct 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 + 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) -> @@ -1413,36 +1432,44 @@ module Raw = struct 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 @@ -1510,7 +1537,8 @@ module Raw = struct let accu = aux 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 value = accu in + let comb, stack = stack in let rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> @@ -1542,7 +1570,8 @@ module Raw = struct (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) | ITicket_deprecated (_, _, k) -> ( - let contents = accu and amount, stack = stack in + let contents = accu in + let amount, stack = stack in match Ticket_amount.of_n amount with | Some amount -> let ticketer = Contract.Originated sc.self in @@ -1550,7 +1579,8 @@ module Raw = struct (step [@ocaml.tailcall]) g gas k ks accu stack | None -> tzfail Script_tc_errors.Forbidden_zero_ticket_quantity) | ITicket (_, _, k) -> ( - let contents = accu and amount, stack = stack in + let contents = accu in + let amount, stack = stack in match Ticket_amount.of_n amount with | Some amount -> let ticketer = Contract.Originated sc.self in @@ -1567,7 +1597,8 @@ module Raw = struct in (step [@ocaml.tailcall]) g gas k ks accu stack | ISplit_ticket (_, k) -> - let ticket = accu and (amount_a, amount_b), stack = stack in + let ticket = accu in + let (amount_a, amount_b), stack = stack in let result = Option.bind (Ticket_amount.of_n amount_a) @@ fun amount_a -> Option.bind (Ticket_amount.of_n amount_b) @@ fun amount_b -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 8c847f2943e53..06d0b14535562 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -174,20 +174,21 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let y, _ = stack in Interp_costs.ediv_nat x y | ILsl_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsl_nat x - | ILsl_bytes _, _, _ -> + | ILsl_bytes _, (accu : bytes), (stack : _ Script_int.num * _) -> let x = accu in let y, _ = stack in Interp_costs.lsl_bytes x y | ILsr_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsr_nat x - | ILsr_bytes _, _, _ -> + | ILsr_bytes _, (accu : bytes), (stack : _ Script_int.num * _) -> let x = accu in let y, _ = stack in Interp_costs.lsr_bytes x y | IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> let y, _ = stack in Interp_costs.or_nat x y - | IOr_bytes _, _, _ -> - let x = accu and y, _ = stack in + | IOr_bytes _, (accu : bytes), (stack : bytes * _) -> + let x = accu in + let y, _ = stack in Interp_costs.or_bytes x y | IAnd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> let y, _ = stack in @@ -195,17 +196,19 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = | IAnd_int_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> let y, _ = stack in Interp_costs.and_int_nat x y - | IAnd_bytes _, _, _ -> - let x = accu and y, _ = stack in + | IAnd_bytes _, (accu : bytes), (stack : bytes * _) -> + let x = accu in + let y, _ = stack in Interp_costs.and_bytes x y | IXor_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> let y, _ = stack in Interp_costs.xor_nat x y - | IXor_bytes _, _, _ -> - let x = accu and y, _ = stack in + | IXor_bytes _, (accu : bytes), (stack : bytes * _) -> + let x = accu in + let y, _ = stack in Interp_costs.xor_bytes x y | INot_int _, (x : _ Script_int.num), _ -> Interp_costs.not_int x - | INot_bytes _, _, _ -> + | INot_bytes _, (accu : bytes), _ -> let x = accu in Interp_costs.not_bytes x | ICompare (_, ty, _), a, (stack : a * _) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 3eb7f9641996c..0991d4b8632d7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -481,6 +481,23 @@ module type MICHELSON_PARSER = sig ('a * t) tzresult Lwt.t end +module type S_Internal_for_benchmarking = sig + val unparse_data : + context -> + stack_depth:int -> + unparsing_mode -> + ('a, 'ac) ty -> + 'a -> + (Script.node * context) tzresult Lwt.t + + val unparse_code : + context -> + stack_depth:int -> + unparsing_mode -> + Script.node -> + (Script.node * context) tzresult Lwt.t +end + module type DATA_UNPARSER = sig (** [unparse_data_aux ctxt ~stack_depth unparsing_mode ty data] returns the Micheline representation of [data] of type [ty], consuming an appropriate @@ -517,22 +534,7 @@ module type DATA_UNPARSER = sig Script.node -> (Script.expr * context, error trace) result Lwt.t - module Internal_for_benchmarking : sig - val unparse_data : - context -> - stack_depth:int -> - unparsing_mode -> - ('a, 'ac) ty -> - 'a -> - (Script.node * context) tzresult Lwt.t - - val unparse_code : - context -> - stack_depth:int -> - unparsing_mode -> - Script.node -> - (Script.node * context) tzresult Lwt.t - end + module Internal_for_benchmarking : S_Internal_for_benchmarking end module Data_unparser (P : MICHELSON_PARSER) : DATA_UNPARSER = struct diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index 47c91bbd0b517..89be664ba76a1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -170,6 +170,23 @@ module type MICHELSON_PARSER = sig ('a * t) tzresult Lwt.t end +module type S_Internal_for_benchmarking = sig + val unparse_data : + context -> + stack_depth:int -> + unparsing_mode -> + ('a, 'ac) ty -> + 'a -> + (Script.node * context) tzresult Lwt.t + + val unparse_code : + context -> + stack_depth:int -> + unparsing_mode -> + Script.node -> + (Script.node * context) tzresult Lwt.t +end + module type DATA_UNPARSER = sig (** [unparse_data_aux ctxt ~stack_depth unparsing_mode ty data] returns the Micheline representation of [data] of type [ty], consuming an appropriate @@ -209,22 +226,7 @@ module type DATA_UNPARSER = sig (** For benchmarking purpose, we also export versions of the unparsing functions which don't call location stripping. These functions are not carbonated and should not be called directly from the protocol. *) - module Internal_for_benchmarking : sig - val unparse_data : - context -> - stack_depth:int -> - unparsing_mode -> - ('a, 'ac) ty -> - 'a -> - (Script.node * context) tzresult Lwt.t - - val unparse_code : - context -> - stack_depth:int -> - unparsing_mode -> - Script.node -> - (Script.node * context) tzresult Lwt.t - end + module Internal_for_benchmarking : S_Internal_for_benchmarking end module Data_unparser (P : MICHELSON_PARSER) : DATA_UNPARSER diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 00f9cc86750f2..a7ec1cb88f9fa 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1254,26 +1254,30 @@ and logger = { } and ('a, 's, 'r, 'f) klog = - logger -> - Local_gas_counter.outdated_context * step_constants -> - Local_gas_counter.local_gas_counter -> - ('a, 's) stack_ty -> - ('a, 's, 'r, 'f) continuation -> - ('a, 's, 'r, 'f) continuation -> - 'a -> - 's -> - ('r - * 'f - * Local_gas_counter.outdated_context - * Local_gas_counter.local_gas_counter) - tzresult - Lwt.t + | Klog of + (logger -> + Local_gas_counter.outdated_context * step_constants -> + Local_gas_counter.local_gas_counter -> + ('a, 's) stack_ty -> + ('a, 's, 'r, 'f) continuation -> + ('a, 's, 'r, 'f) continuation -> + 'a -> + 's -> + ('r + * 'f + * Local_gas_counter.outdated_context + * Local_gas_counter.local_gas_counter) + tzresult + Lwt.t) +[@@coq_force_gadt] and ('a, 's, 'b, 't, 'r, 'f) ilog = - logger -> - logging_event -> - ('a, 's) stack_ty -> - ('a, 's, 'b, 't, 'r, 'f) step_type + | Ilog of + (logger -> + logging_event -> + ('a, 's) stack_ty -> + ('a, 's, 'b, 't, 'r, 'f) step_type) +[@@coq_force_gadt] and ('a, 's, 'b, 't, 'r, 'f) step_type = Local_gas_counter.outdated_context * step_constants -> @@ -1290,10 +1294,12 @@ and ('a, 's, 'b, 't, 'r, 'f) step_type = Lwt.t and ('a, 'b, 'c, 'd) log_kinstr = - logger -> - ('a, 'b) stack_ty -> - ('a, 'b, 'c, 'd) kinstr -> - ('a, 'b, 'c, 'd) kinstr + | Log_kinstr of + (logger -> + ('a, 'b) stack_ty -> + ('a, 'b, 'c, 'd) kinstr -> + ('a, 'b, 'c, 'd) kinstr) +[@@coq_force_gadt] (* ---- Auxiliary types -----------------------------------------------------*) and ('ty, 'comparable) ty = diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index c7b7f1af7eee6..4a84eaa664aa7 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1367,26 +1367,30 @@ and logger = { } and ('a, 's, 'r, 'f) klog = - logger -> - Local_gas_counter.outdated_context * step_constants -> - Local_gas_counter.local_gas_counter -> - ('a, 's) stack_ty -> - ('a, 's, 'r, 'f) continuation -> - ('a, 's, 'r, 'f) continuation -> - 'a -> - 's -> - ('r - * 'f - * Local_gas_counter.outdated_context - * Local_gas_counter.local_gas_counter) - tzresult - Lwt.t + | Klog of + (logger -> + Local_gas_counter.outdated_context * step_constants -> + Local_gas_counter.local_gas_counter -> + ('a, 's) stack_ty -> + ('a, 's, 'r, 'f) continuation -> + ('a, 's, 'r, 'f) continuation -> + 'a -> + 's -> + ('r + * 'f + * Local_gas_counter.outdated_context + * Local_gas_counter.local_gas_counter) + tzresult + Lwt.t) +[@@coq_force_gadt] and ('a, 's, 'b, 't, 'r, 'f) ilog = - logger -> - logging_event -> - ('a, 's) stack_ty -> - ('a, 's, 'b, 't, 'r, 'f) step_type + | Ilog of + (logger -> + logging_event -> + ('a, 's) stack_ty -> + ('a, 's, 'b, 't, 'r, 'f) step_type) +[@@coq_force_gadt] and ('a, 's, 'b, 't, 'r, 'f) step_type = Local_gas_counter.outdated_context * step_constants -> @@ -1403,10 +1407,12 @@ and ('a, 's, 'b, 't, 'r, 'f) step_type = Lwt.t and ('a, 'b, 'c, 'd) log_kinstr = - logger -> - ('a, 'b) stack_ty -> - ('a, 'b, 'c, 'd) kinstr -> - ('a, 'b, 'c, 'd) kinstr + | Log_kinstr of + (logger -> + ('a, 'b) stack_ty -> + ('a, 'b, 'c, 'd) kinstr -> + ('a, 'b, 'c, 'd) kinstr) +[@@coq_force_gadt] (* ---- Auxiliary types -----------------------------------------------------*) and ('ty, 'comparable) ty = diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 1161082591352..37a8d377a8630 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -207,7 +207,11 @@ module Contract = struct end) (Tez_repr) - module Missed_endorsements = + module Missed_endorsements : + Indexed_data_storage + with type key = Contract_repr.t + and type value = missed_endorsements_info + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -223,7 +227,11 @@ module Contract = struct end) (Manager_repr) - module Consensus_key = + module Consensus_key : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Signature.Public_key.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -240,7 +248,11 @@ module Contract = struct (Make_index (Cycle_repr.Index)) (Signature.Public_key) - module Delegate = + module Delegate : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Signature.Public_key_hash.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -255,7 +267,11 @@ module Contract = struct let name = ["inactive_delegate"] end) - module Delegate_last_cycle_before_deactivation = + module Delegate_last_cycle_before_deactivation : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Cycle_repr.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -357,7 +373,11 @@ module Contract = struct let name = ["storage"] end) - module Paid_storage_space = + module Paid_storage_space : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -365,7 +385,11 @@ module Contract = struct end) (Encoding.Z) - module Used_storage_space = + module Used_storage_space : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Z.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -373,7 +397,11 @@ module Contract = struct end) (Encoding.Z) - module Frozen_deposits = + module Frozen_deposits : + Indexed_data_storage + with type key = Contract_repr.t + and type value = deposits + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -381,7 +409,11 @@ module Contract = struct end) (Deposits) - module Frozen_deposits_limit = + module Frozen_deposits_limit : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Tez_repr.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -407,7 +439,11 @@ module Contract = struct let fold_bond_ids = Bond_id_index.fold_keys - module Total_frozen_bonds = + module Total_frozen_bonds : + Indexed_data_storage + with type key = Contract_repr.t + and type value = Tez_repr.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -500,7 +536,11 @@ module Big_map = struct end) (Encoding.Z) - module Key_type = + module Key_type : + Indexed_data_storage + with type key = id + and type value = Script_repr.expr + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -512,7 +552,11 @@ module Big_map = struct let encoding = Script_repr.expr_encoding end) - module Value_type = + module Value_type : + Indexed_data_storage + with type key = id + and type value = Script_repr.expr + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -1012,7 +1056,11 @@ module Cycle = struct (req "active_stake" Tez_repr.encoding))) end) - module Total_active_stake = + module Total_active_stake : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Tez_repr.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -1020,7 +1068,11 @@ module Cycle = struct end) (Tez_repr) - module Delegate_sampler_state = + module Delegate_sampler_state : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = Raw_context.consensus_pk Sampler.t + and type t := Raw_context.t = Indexed_context.Make_map (Registered) (struct @@ -1116,7 +1168,13 @@ module Stake = struct let encoding = Data_encoding.unit end) - module Selected_distribution_for_cycle = Cycle.Selected_stake_distribution + module Selected_distribution_for_cycle : + Indexed_data_storage + with type key = Cycle_repr.t + and type value = (Signature.Public_key_hash.t * Tez_repr.t) list + and type t := Raw_context.t = + Cycle.Selected_stake_distribution + module Total_active_stake = Cycle.Total_active_stake (* This is an index that is set to 0 by calls to @@ -1699,8 +1757,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_commitment_repr.genesis_info_encoding end) - module Inbox = struct - include + module Inbox : + Single_data_storage + with type value = Sc_rollup_inbox_repr.t + and type t := Raw_context.t = struct + module Inbox = Make_single_data_storage (Registered) (Raw_context) (struct let name = ["sc_rollup_inbox"] @@ -1711,6 +1772,14 @@ module Sc_rollup = struct let encoding = Sc_rollup_inbox_repr.versioned_encoding end) + type context = Inbox.context + + let mem = Inbox.mem + + let remove_existing = Inbox.remove_existing + + let remove = Inbox.remove + type value = Sc_rollup_inbox_repr.t let of_versioned = Sc_rollup_inbox_repr.of_versioned @@ -1719,24 +1788,24 @@ module Sc_rollup = struct let get ctxt = let open Lwt_result_syntax in - let* versioned = get ctxt in + let* versioned = Inbox.get ctxt in return (of_versioned versioned) let find ctxt = let open Lwt_result_syntax in - let* versioned = find ctxt in + let* versioned = Inbox.find ctxt in return (Option.map of_versioned versioned) - let init ctxt value = init ctxt (to_versioned value) + let init ctxt value = Inbox.init ctxt (to_versioned value) - let update ctxt value = update ctxt (to_versioned value) + let update ctxt value = Inbox.update ctxt (to_versioned value) let add ctxt value = let versioned = to_versioned value in - add ctxt versioned + Inbox.add ctxt versioned let add_or_remove ctxt value = - add_or_remove ctxt (Option.map to_versioned value) + Inbox.add_or_remove ctxt (Option.map to_versioned value) end module Last_cemented_commitment = @@ -1837,7 +1906,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitment_first_publication_level = + module Commitment_first_publication_level : + Non_iterable_indexed_carbonated_data_storage + with type key = Raw_level_repr.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 @@ -2025,7 +2098,11 @@ module Dal = struct end)) (Make_index (Raw_level_repr.Index)) - module Headers = + module 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.Header.t list = Level_context.Make_map (Registered) (struct diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index 155419b02e641..99cc9b6f866e9 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -1051,6 +1051,8 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : Raw_context.Local_context.remove_existing local N.name let remove local = Raw_context.Local_context.remove local N.name + + let _sig_Local = () end end diff --git a/src/proto_alpha/lib_protocol/storage_sigs.ml b/src/proto_alpha/lib_protocol/storage_sigs.ml index 9f6e4547c65e8..2e370236923ef 100644 --- a/src/proto_alpha/lib_protocol/storage_sigs.ml +++ b/src/proto_alpha/lib_protocol/storage_sigs.ml @@ -279,53 +279,64 @@ module type Indexed_data_storage = sig 'a Lwt.t end -module type Indexed_data_storage_with_local_context = sig - include Indexed_data_storage +module type Indexed_data_storage_with_local_context_Local = sig + type value type local_context - module Local : sig - type context = local_context + type context = local_context - (** Tells if the data is already defined *) - val mem : context -> bool Lwt.t + (** Tells if the data is already defined *) + val mem : context -> bool Lwt.t - (** Retrieves the value from the storage bucket; returns a - {!Storage_error} if the key is not set or if the deserialisation - fails *) - val get : context -> value tzresult Lwt.t + (** Retrieves the value from the storage bucket; returns a + {!Storage_error} if the key is not set or if the deserialisation + fails *) + val get : context -> value tzresult Lwt.t - (** Retrieves the value from the storage bucket ; returns [None] if - the data is not initialized, or {!Storage_helpers.Storage_error} - if the deserialisation fails *) - val find : context -> value option tzresult Lwt.t + (** Retrieves the value from the storage bucket ; returns [None] if + the data is not initialized, or {!Storage_helpers.Storage_error} + if the deserialisation fails *) + val find : context -> value option tzresult Lwt.t - (** Allocates the storage bucket and initializes it ; returns a - {!Storage_error Existing_key} if the bucket exists *) - val init : context -> value -> context tzresult Lwt.t + (** Allocates the storage bucket and initializes it ; returns a + {!Storage_error Existing_key} if the bucket exists *) + val init : context -> value -> context tzresult Lwt.t - (** Updates the content of the bucket; returns a {!Storage_Error - Missing_key} if the value does not exist *) - val update : context -> value -> context tzresult Lwt.t + (** Updates the content of the bucket; returns a {!Storage_Error + Missing_key} if the value does not exist *) + val update : context -> value -> context tzresult Lwt.t - (** Allocates the data and initializes it with a value ; just - updates it if the bucket exists *) - val add : context -> value -> context Lwt.t + (** Allocates the data and initializes it with a value ; just + updates it if the bucket exists *) + val add : context -> value -> context Lwt.t + + (** When the value is [Some v], allocates the data and initializes + it with [v] ; just updates it if the bucket exists. When the + value is [None], deletes the storage bucket; it does + nothing if the bucket does not exists. *) + val add_or_remove : context -> value option -> context Lwt.t + + (** Delete the storage bucket ; returns a {!Storage_error + Missing_key} if the bucket does not exists *) + val remove_existing : context -> context tzresult Lwt.t + + (** Removes the storage bucket and its contents; does nothing if + the bucket does not exist *) + val remove : context -> context Lwt.t - (** When the value is [Some v], allocates the data and initializes - it with [v] ; just updates it if the bucket exists. When the - value is [None], deletes the storage bucket; it does - nothing if the bucket does not exists. *) - val add_or_remove : context -> value option -> context Lwt.t + val _sig_Local : unit +end - (** Delete the storage bucket ; returns a {!Storage_error - Missing_key} if the bucket does not exists *) - val remove_existing : context -> context tzresult Lwt.t +module type Indexed_data_storage_with_local_context = sig + include Indexed_data_storage + + type local_context - (** Removes the storage bucket and its contents; does nothing if - the bucket does not exist *) - val remove : context -> context Lwt.t - end + module Local : + Indexed_data_storage_with_local_context_Local + with type value := value + and type local_context := local_context end module type Indexed_data_snapshotable_storage = sig diff --git a/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml b/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml index e6eb55c04cb98..26f647aa99c0a 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/dummy_zk_rollup.ml @@ -339,7 +339,7 @@ end) : sig val init_state : Zk_rollup.State.t (** Map associating every circuit identifier to its kind *) - val circuits : [`Public | `Private | `Fee] Plonk.Main_protocol.SMap.t + val circuits : Zk_rollup.Account.circuit_info Plonk.Main_protocol.SMap.t (** Commitment to the circuits *) val public_parameters : @@ -438,7 +438,10 @@ end = struct ] let circuits = - SMap.(add "op" `Public @@ add batch_name `Private @@ add "fee" `Fee empty) + SMap.( + add "op" Zk_rollup.Account.Public + @@ add batch_name Zk_rollup.Account.Private + @@ add "fee" Zk_rollup.Account.Fee empty) let public_parameters, prover_pp = let (ppp, vpp), t = diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 13760980995c1..e0e945f6c97aa 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -743,7 +743,7 @@ val zk_rollup_origination : public_parameters: Plonk.Main_protocol.verifier_public_parameters * Plonk.Main_protocol.transcript -> - circuits_info:[`Public | `Private | `Fee] Zk_rollup.Account.SMap.t -> + circuits_info:Zk_rollup.Account.circuit_info Zk_rollup.Account.SMap.t -> init_state:Zk_rollup.State.t -> nb_ops:int -> (Operation.packed * Zk_rollup.t) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index 5c26c35f5431d..190d7c8e0bb25 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -99,7 +99,7 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = in Ticket_token_map.of_list_with_merge ctxt token_amounts -let update_ticket_balances ctxt ~total_storage_diff token destinations = +let update_ticket_balances_aux ctxt ~total_storage_diff token destinations = let open Lwt_result_syntax in List.fold_left_es (fun (tot_storage_diff, ctxt) (owner, delta) -> @@ -138,7 +138,7 @@ let update_ticket_balances_for_self_contract ctxt ~self_contract ticket_diffs = is_valid_balance_update (invalid_ticket_transfer_error ~ticket_token ~amount) in - update_ticket_balances + update_ticket_balances_aux ctxt ~total_storage_diff ticket_token @@ -291,6 +291,10 @@ let update_ticket_balances ctxt ~self_contract ~ticket_diffs operations = ([], ctxt) destinations in - update_ticket_balances ctxt ~total_storage_diff ticket_token destinations) + update_ticket_balances_aux + ctxt + ~total_storage_diff + ticket_token + destinations) (total_storage_diff, ctxt) ticket_op_diffs diff --git a/src/proto_alpha/lib_protocol/ticket_transfer.ml b/src/proto_alpha/lib_protocol/ticket_transfer.ml index 57b295a6730e3..397489945459e 100644 --- a/src/proto_alpha/lib_protocol/ticket_transfer.ml +++ b/src/proto_alpha/lib_protocol/ticket_transfer.ml @@ -32,11 +32,11 @@ 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 - ctxt - contents_type - (Micheline.root contents) + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data + ctxt + contents_type + (Micheline.root contents) [@coq_type_annotation]) >>=? fun (contents, ctxt) -> let token = Ticket_token.Ex_token {ticketer; contents_type; contents} in return (ctxt, token) diff --git a/src/proto_alpha/lib_protocol/zk_rollup_account_repr.ml b/src/proto_alpha/lib_protocol/zk_rollup_account_repr.ml index 18d96d4a516b3..21c8d0d04df1c 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_account_repr.ml +++ b/src/proto_alpha/lib_protocol/zk_rollup_account_repr.ml @@ -25,10 +25,12 @@ module SMap = Map.Make (String) +type circuit_info = Public | Private | Fee + type static = { public_parameters : Plonk.public_parameters; state_length : int; - circuits_info : [`Public | `Private | `Fee] SMap.t; + circuits_info : circuit_info SMap.t; nb_ops : int; } @@ -40,8 +42,7 @@ type dynamic = { type t = {static : static; dynamic : dynamic} -let circuits_info_encoding : [`Public | `Private | `Fee] SMap.t Data_encoding.t - = +let circuits_info_encoding : circuit_info SMap.t Data_encoding.t = let open Data_encoding in let variant_encoding = let public_tag, public_encoding = (0, obj1 @@ req "public" unit) in @@ -49,28 +50,28 @@ let circuits_info_encoding : [`Public | `Private | `Fee] SMap.t Data_encoding.t let fee_tag, fee_encoding = (2, obj1 @@ req "fee" unit) in matching (function - | `Public -> matched public_tag public_encoding () - | `Private -> matched private_tag private_encoding () - | `Fee -> matched fee_tag fee_encoding ()) + | Public -> matched public_tag public_encoding () + | Private -> matched private_tag private_encoding () + | Fee -> matched fee_tag fee_encoding ()) [ case ~title:"Public" (Tag public_tag) public_encoding - (function `Public -> Some () | _ -> None) - (fun () -> `Public); + (function Public -> Some () | _ -> None) + (fun () -> Public); case ~title:"Private" (Tag private_tag) private_encoding - (function `Private -> Some () | _ -> None) - (fun () -> `Private); + (function Private -> Some () | _ -> None) + (fun () -> Private); case ~title:"Fee" (Tag fee_tag) fee_encoding - (function `Fee -> Some () | _ -> None) - (fun () -> `Fee); + (function Fee -> Some () | _ -> None) + (fun () -> Fee); ] in conv_with_guard diff --git a/src/proto_alpha/lib_protocol/zk_rollup_account_repr.mli b/src/proto_alpha/lib_protocol/zk_rollup_account_repr.mli index 57c133098a1a8..398494574548d 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_account_repr.mli +++ b/src/proto_alpha/lib_protocol/zk_rollup_account_repr.mli @@ -27,6 +27,8 @@ module SMap : Map.S with type key = string (** Representation of a ZK Rollup account. *) +type circuit_info = Public | Private | Fee + (** Static part of a ZKRU account. These are set at origination, after which they cannot be modified. *) type static = { @@ -34,7 +36,7 @@ type static = { (** Input to the Plonk verifier that are fixed once the circuits are decided. *) state_length : int; (** Number of scalars in the state. *) - circuits_info : [`Public | `Private | `Fee] SMap.t; + circuits_info : circuit_info SMap.t; (** Circuit names, alongside a tag indicating its kind. *) nb_ops : int; (** Valid op codes of L2 operations must be in \[0, nb_ops) *) } @@ -58,4 +60,4 @@ val encoding : t Data_encoding.t (* Encoding for the [circuits_info] field. Checks that keys are not duplicated in serialized representation. *) -val circuits_info_encoding : [`Public | `Private | `Fee] SMap.t Data_encoding.t +val circuits_info_encoding : circuit_info SMap.t Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/zk_rollup_apply.ml b/src/proto_alpha/lib_protocol/zk_rollup_apply.ml index f1b7cc01889a0..819b69c7a6884 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_apply.ml +++ b/src/proto_alpha/lib_protocol/zk_rollup_apply.ml @@ -318,7 +318,7 @@ let collect_pivate_batch_inputs ~zk_rollup ~account ~rev_pi_map ~update let open Lwt_result_syntax in let open Zk_rollup.Update in let open Zk_rollup.Account in - let is_private = function Some `Private -> true | _ -> false in + let is_private = function Some Private -> true | _ -> false in List.fold_left_es (fun (rev_pi_map, old_state, fees) (name, (sent_pi : private_inner_pi)) -> let*? () = diff --git a/src/proto_alpha/lib_protocol/zk_rollup_apply.mli b/src/proto_alpha/lib_protocol/zk_rollup_apply.mli index 7e01854acc3ac..a1ddcfafa9495 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_apply.mli +++ b/src/proto_alpha/lib_protocol/zk_rollup_apply.mli @@ -122,7 +122,7 @@ val originate : ctxt_before_op:t -> ctxt:t -> public_parameters:Plonk.public_parameters -> - circuits_info:[`Public | `Private | `Fee] Zk_rollup.Account.SMap.t -> + circuits_info:Zk_rollup.Account.circuit_info Zk_rollup.Account.SMap.t -> init_state:Zk_rollup.State.t -> nb_ops:int -> (t diff --git a/src/proto_alpha/lib_protocol/zk_rollup_storage.ml b/src/proto_alpha/lib_protocol/zk_rollup_storage.ml index 26ad6dda3b717..6113fdd747c09 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/zk_rollup_storage.ml @@ -205,11 +205,11 @@ let get_pending_length ctxt rollup = return (ctxt, pending_length pl) (** Same as [Tezos_stdlib.Utils.fold_n_times] but with Lwt and Error monad *) -let fold_n_times_es ~when_negative n f e = +let fold_n_times_es ~when_negative n f e : _ tzresult Lwt.t = let open Lwt_result_syntax in if Compare.Int.(n < 0) then tzfail when_negative else - let rec go acc = function + let[@coq_struct "function_parameter"] rec go acc = function | 0 -> return acc | n -> let* acc = f acc in -- GitLab From 9fea8f55c9a3f614e3c97d990263698541a4c901 Mon Sep 17 00:00:00 2001 From: Andrey Klaus Date: Fri, 23 Sep 2022 11:43:49 +0000 Subject: [PATCH 3/3] removing asserts - actual --- src/lib_protocol_environment/sigs/v8.ml | 1 + .../sigs/v8/compare.mli | 1 + .../script_interpreter_logging.ml | 158 ++++++------- .../bin_sc_rollup_node/RPC_server.ml | 2 +- .../bin_sc_rollup_node/arith_pvm.ml | 3 +- .../bin_sc_rollup_node/wasm_2_0_0_pvm.ml | 3 +- .../interpreter_workload.ml | 43 ++-- .../sc_rollup_benchmarks.ml | 50 ++-- .../storage_benchmarks.ml | 6 +- .../lib_client/client_proto_rollups.ml | 14 +- src/proto_alpha/lib_plugin/RPC.ml | 37 +-- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + src/proto_alpha/lib_protocol/alpha_context.ml | 18 +- .../lib_protocol/alpha_context.mli | 64 +++--- .../lib_protocol/alpha_services.ml | 3 +- src/proto_alpha/lib_protocol/amendment.ml | 8 +- src/proto_alpha/lib_protocol/apply.ml | 35 +-- src/proto_alpha/lib_protocol/bond_id_repr.ml | 13 +- .../lib_protocol/bounded_history_repr.ml | 2 +- src/proto_alpha/lib_protocol/cache_repr.ml | 52 +++-- src/proto_alpha/lib_protocol/cache_repr.mli | 2 +- .../contract_delegate_storage.mli | 4 +- src/proto_alpha/lib_protocol/contract_repr.ml | 20 +- .../lib_protocol/contract_repr.mli | 4 +- .../lib_protocol/contract_services.ml | 2 +- .../lib_protocol/contract_storage.ml | 77 ++++--- .../lib_protocol/contract_storage.mli | 8 +- src/proto_alpha/lib_protocol/cycle_repr.ml | 17 +- src/proto_alpha/lib_protocol/cycle_repr.mli | 4 +- src/proto_alpha/lib_protocol/dal_services.ml | 2 +- .../lib_protocol/dal_slot_storage.ml | 4 +- .../delegate_activation_storage.ml | 7 +- .../lib_protocol/delegate_consensus_key.ml | 13 +- .../lib_protocol/delegate_cycles.ml | 29 ++- .../delegate_missed_endorsements_storage.ml | 4 +- .../lib_protocol/delegate_sampler.ml | 10 +- .../lib_protocol/delegate_services.ml | 6 +- .../delegate_slashed_deposits_storage.ml | 28 ++- .../delegate_slashed_deposits_storage.mli | 2 +- .../lib_protocol/delegate_storage.mli | 6 +- src/proto_alpha/lib_protocol/dune | 2 + .../lib_protocol/gas_input_size.ml | 10 +- .../lib_protocol/gas_input_size.mli | 4 +- .../lib_protocol/internal_errors.ml | 8 + .../lib_protocol/lazy_storage_kind.ml | 8 +- src/proto_alpha/lib_protocol/level_repr.ml | 154 ++++++++----- src/proto_alpha/lib_protocol/level_repr.mli | 14 +- src/proto_alpha/lib_protocol/level_storage.ml | 75 +++--- .../lib_protocol/level_storage.mli | 30 +-- src/proto_alpha/lib_protocol/main.ml | 9 +- src/proto_alpha/lib_protocol/path_encoding.ml | 12 +- .../lib_protocol/path_encoding.mli | 4 +- src/proto_alpha/lib_protocol/raw_context.ml | 122 +++++----- src/proto_alpha/lib_protocol/raw_context.mli | 6 +- .../lib_protocol/raw_level_repr.ml | 33 ++- .../lib_protocol/raw_level_repr.mli | 8 +- src/proto_alpha/lib_protocol/sampler.ml | 12 +- src/proto_alpha/lib_protocol/sampler.mli | 3 +- .../lib_protocol/sapling_storage.ml | 82 ++++--- .../lib_protocol/sapling_validator.ml | 93 ++++---- .../lib_protocol/sc_rollup_arith.ml | 25 +- .../lib_protocol/sc_rollup_commitment_repr.ml | 14 +- .../sc_rollup_commitment_repr.mli | 2 +- .../lib_protocol/sc_rollup_game_repr.ml | 6 +- .../lib_protocol/sc_rollup_game_repr.mli | 4 +- .../lib_protocol/sc_rollup_operations.ml | 2 +- .../lib_protocol/sc_rollup_proof_repr.ml | 18 +- .../sc_rollup_refutation_storage.ml | 43 ++-- .../lib_protocol/sc_rollup_repr.ml | 26 +-- .../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_wasm.ml | 46 ++-- src/proto_alpha/lib_protocol/script_cache.ml | 9 +- .../lib_protocol/script_interpreter.ml | 17 +- .../lib_protocol/script_ir_translator.ml | 32 +-- src/proto_alpha/lib_protocol/seed_storage.ml | 27 ++- src/proto_alpha/lib_protocol/stake_storage.ml | 11 +- .../lib_protocol/stake_storage.mli | 4 +- src/proto_alpha/lib_protocol/storage.ml | 95 +++++--- src/proto_alpha/lib_protocol/storage.mli | 16 +- .../lib_protocol/storage_functors.ml | 172 +++++++++----- src/proto_alpha/lib_protocol/storage_sigs.ml | 34 +-- .../lib_protocol/test/helpers/block.ml | 12 +- .../lib_protocol/test/helpers/incremental.ml | 4 +- .../test/helpers/sapling_helpers.ml | 216 +++++++++--------- .../test/helpers/sc_rollup_helpers.ml | 14 +- .../lib_protocol/tx_rollup_commitment_repr.ml | 13 +- .../tx_rollup_commitment_storage.ml | 11 +- .../lib_protocol/tx_rollup_level_repr.mli | 4 +- .../lib_protocol/tx_rollup_repr.ml | 13 +- src/proto_alpha/lib_protocol/validate.ml | 19 +- src/proto_alpha/lib_protocol/vote_storage.ml | 42 ++-- src/proto_alpha/lib_protocol/vote_storage.mli | 9 +- .../lib_protocol/voting_services.ml | 5 +- .../lib_protocol/zk_rollup_repr.ml | 13 +- 96 files changed, 1396 insertions(+), 1059 deletions(-) create mode 100644 src/proto_alpha/lib_protocol/internal_errors.ml diff --git a/src/lib_protocol_environment/sigs/v8.ml b/src/lib_protocol_environment/sigs/v8.ml index e4ded7cbd233d..7c6e9c2c92d8c 100644 --- a/src/lib_protocol_environment/sigs/v8.ml +++ b/src/lib_protocol_environment/sigs/v8.ml @@ -5417,6 +5417,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/v8/compare.mli b/src/lib_protocol_environment/sigs/v8/compare.mli index 22e295139c479..70dbae5d347c3 100644 --- a/src/lib_protocol_environment/sigs/v8/compare.mli +++ b/src/lib_protocol_environment/sigs/v8/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/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml b/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml index 8b755e26f60cb..d09762eca53a0 100644 --- a/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml +++ b/src/proto_015_PtLimaPt/lib_protocol/script_interpreter_logging.ml @@ -98,13 +98,11 @@ type ('a, 's, 'r, 'f) ex_split_kinstr = cast : ('a, 's) failed_kinstr_cast; } -> ('a, 's, 'r, 'f) ex_split_kinstr -[@@coq_force_gadt] type ('r, 'f) ex_init_stack_ty = | Ex_init_stack_ty : ('a, 's) stack_ty * ('a, 's, 'r, 'f) kinstr -> ('r, 'f) ex_init_stack_ty -[@@coq_force_gadt] let rec stack_prefix_preservation_witness_split_input : type a s b t c u d v. @@ -112,7 +110,7 @@ let rec stack_prefix_preservation_witness_split_input : (a, s) stack_ty -> (b, t) stack_ty = fun w s -> - match[@coq_match_with_default] (w, s) with + match (w, s) with | KPrefix (_, _, w), Item_t (_, s) -> stack_prefix_preservation_witness_split_input w s | KRest, s -> s @@ -139,7 +137,7 @@ let kinstr_split : (a, s, r, f) ex_split_kinstr tzresult = fun s i -> let dummy = Micheline.dummy_location in - match[@coq_match_with_default] (i, s) with + match (i, s) with | IDrop (loc, k), Item_t (_a, s) -> ok @@ Ex_split_kinstr @@ -251,7 +249,7 @@ let kinstr_split : body; continuation = k; aft_body_stack_transform = - (function[@coq_match_with_default] + (function | Item_t (b, s) -> option_t dummy b >|? fun o -> Item_t (o, s)); reconstruct = (fun body k -> IOpt_map {loc; body; k}); } @@ -328,7 +326,7 @@ let kinstr_split : body; continuation = k; aft_body_stack_transform = - (function[@coq_match_with_default] + (function | Item_t (b, s) -> list_t dummy b >|? fun l -> Item_t (l, s)); reconstruct = (fun body k -> IList_map (loc, body, ty, k)); } @@ -405,20 +403,19 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> IEmpty_map (loc, cty, vty, k)); } - | IMap_map (loc, ty, body, k), Item_t (Map_t (kty, vty, _meta), s) -> ( - match[@coq_match_with_default] assert_some ty with - | Map_t (key_ty, _, _) -> - pair_t dummy key_ty vty >|? fun (Ty_ex_c p) -> - Ex_split_loop_may_not_fail - { - body_init_stack = Item_t (p, s); - body; - continuation = k; - aft_body_stack_transform = - (fun [@coq_match_with_default] (Item_t (b, s)) -> - map_t dummy kty b >|? fun m -> Item_t (m, s)); - reconstruct = (fun body k -> IMap_map (loc, ty, body, k)); - }) + | IMap_map (loc, ty, body, k), Item_t (Map_t (kty, vty, _meta), s) -> + let (Map_t (key_ty, _, _)) = assert_some ty in + pair_t dummy key_ty vty >|? fun (Ty_ex_c p) -> + Ex_split_loop_may_not_fail + { + body_init_stack = Item_t (p, s); + body; + continuation = k; + aft_body_stack_transform = + (fun (Item_t (b, s)) -> + map_t dummy kty b >|? fun m -> Item_t (m, s)); + reconstruct = (fun body k -> IMap_map (loc, ty, body, k)); + } | IMap_iter (loc, kvty, body, k), Item_t (_, stack) -> ok @@ Ex_split_loop_may_fail @@ -930,28 +927,28 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> IApply (loc, ty, k)); } - | ILambda (loc, (Lam (desc, _) as l), k), s -> ( - match[@coq_match_with_default] (desc.kbef, desc.kaft) with - | Item_t (a, Bot_t), Item_t (b, Bot_t) -> - lambda_t dummy a b >|? fun lam -> - let s = Item_t (lam, s) in - Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> ILambda (loc, l, k)); - }) - | ILambda (loc, (LamRec (desc, _) as l), k), s -> ( - match[@coq_match_with_default] (desc.kbef, desc.kaft) with - | Item_t (a, Item_t (Lambda_t _, Bot_t)), Item_t (b, Bot_t) -> - lambda_t dummy a b >|? fun lam -> - let s = Item_t (lam, s) in - Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> ILambda (loc, l, k)); - }) + | ILambda (loc, (Lam (desc, _) as l), k), s -> + let (Item_t (a, Bot_t)) = desc.kbef in + let (Item_t (b, Bot_t)) = desc.kaft in + lambda_t dummy a b >|? fun lam -> + let s = Item_t (lam, s) in + Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> ILambda (loc, l, k)); + } + | ILambda (loc, (LamRec (desc, _) as l), k), s -> + let (Item_t (a, Item_t (Lambda_t _, Bot_t))) = desc.kbef in + let (Item_t (b, Bot_t)) = desc.kaft in + lambda_t dummy a b >|? fun lam -> + let s = Item_t (lam, s) in + Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> ILambda (loc, l, k)); + } | IFailwith (location, arg_ty), _ -> ok @@ Ex_split_failwith @@ -1246,20 +1243,17 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> ISapling_verify_update (loc, k)); } - | IDig (loc, n, p, k), s -> ( - match[@coq_match_with_default] - stack_prefix_preservation_witness_split_input p s - with - | Item_t (b, s) -> - let s = stack_prefix_preservation_witness_split_output p s in - let s = Item_t (b, s) in - ok - @@ Ex_split_kinstr - { - cont_init_stack = s; - continuation = k; - reconstruct = (fun k -> IDig (loc, n, p, k)); - }) + | IDig (loc, n, p, k), s -> + let (Item_t (b, s)) = stack_prefix_preservation_witness_split_input p s in + let s = stack_prefix_preservation_witness_split_output p s in + let s = Item_t (b, s) in + ok + @@ Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> IDig (loc, n, p, k)); + } | IDug (loc, n, p, k), Item_t (a, s) -> let s = stack_prefix_preservation_witness_split_input p s in let s = Item_t (a, s) in @@ -1454,10 +1448,10 @@ let kinstr_split : (a, b, s, c, d, t) comb_gadt_witness -> (c, d * t) stack_ty tzresult = fun s w -> - match[@coq_match_with_default] (w, s) with + match (w, s) with | Comb_one, s -> ok s | Comb_succ w, Item_t (a, s) -> - aux s w >>? fun [@coq_match_with_default] (Item_t (c, t)) -> + aux s w >>? fun (Item_t (c, t)) -> pair_t dummy a c >|? fun (Ty_ex_c p) -> Item_t (p, t) in aux s p >|? fun s -> @@ -1474,7 +1468,7 @@ let kinstr_split : (a, b, s, c, d, t) uncomb_gadt_witness -> (c, d * t) stack_ty = fun s w -> - match[@coq_match_with_default] (w, s) with + match (w, s) with | Uncomb_one, s -> s | Uncomb_succ w, Item_t (Pair_t (a, b, _meta, _), s) -> let s = aux (Item_t (b, s)) w in @@ -1492,7 +1486,7 @@ let kinstr_split : let rec aux : type c cc a. (c, cc) ty -> (c, a) comb_get_gadt_witness -> a ty_ex_c = fun c w -> - match[@coq_match_with_default] (w, c) with + match (w, c) with | Comb_get_zero, c -> Ty_ex_c c | Comb_get_one, Pair_t (hd, _tl, _meta, _) -> Ty_ex_c hd | Comb_get_plus_two w, Pair_t (_hd, tl, _meta, _) -> aux tl w @@ -1516,7 +1510,7 @@ let kinstr_split : (a, b, c) comb_set_gadt_witness -> c ty_ex_c tzresult = fun a b w -> - match[@coq_match_with_default] (w, b) with + match (w, b) with | Comb_set_zero, _ -> ok (Ty_ex_c a) | Comb_set_one, Pair_t (_hd, tl, _meta, _) -> pair_t dummy a tl | Comb_set_plus_two w, Pair_t (hd, tl, _meta, _) -> @@ -1535,7 +1529,7 @@ let kinstr_split : type a b s t. (a, b * s) stack_ty -> (a, b, s, t) dup_n_gadt_witness -> t ty_ex_c = fun s w -> - match[@coq_match_with_default] (w, s) with + match (w, s) with | Dup_n_succ w, Item_t (_, s) -> aux s w | Dup_n_zero, Item_t (a, _) -> Ty_ex_c a in @@ -1635,7 +1629,7 @@ let kinstr_split : reconstruct = (fun k -> ILog (loc, s, event, logger, k)); } -let[@coq_struct "i_value"] rec kinstr_final_stack_type : +let rec kinstr_final_stack_type : type a s r f. (a, s) stack_ty -> (a, s, r, f) kinstr -> (r, f) stack_ty option tzresult = fun s i -> @@ -1798,19 +1792,17 @@ let log_next_continuation : kinstr_final_stack_type stack_ty ki >|? function | None -> KCons (ki', k) | Some sty -> KCons (ki', instrument_cont logger sty k)) - | KLoop_in (ki, k) -> ( - match[@coq_match_with_default] stack_ty with - | Item_t (Bool_t, sty) -> - ok @@ KLoop_in (enable_log sty ki, instrument_cont logger sty k)) + | KLoop_in (ki, k) -> + let (Item_t (Bool_t, sty)) = stack_ty in + ok @@ KLoop_in (enable_log sty ki, instrument_cont logger sty k) | KReturn (stack, sty, k) -> let k' = instrument_cont logger (assert_some sty) k in ok @@ KReturn (stack, sty, k') - | KLoop_in_left (ki, k) -> ( - match[@coq_match_with_default] stack_ty with - | Item_t (Union_t (a_ty, b_ty, _, _), rest) -> - let ki' = enable_log (Item_t (a_ty, rest)) ki in - let k' = instrument_cont logger (Item_t (b_ty, rest)) k in - ok @@ KLoop_in_left (ki', k')) + | KLoop_in_left (ki, k) -> + let (Item_t (Union_t (a_ty, b_ty, _, _), rest)) = stack_ty in + let ki' = enable_log (Item_t (a_ty, rest)) ki in + let k' = instrument_cont logger (Item_t (b_ty, rest)) k in + ok @@ KLoop_in_left (ki', k') | KUndip (x, ty, k) -> let k' = instrument_cont logger (Item_t (assert_some ty, stack_ty)) k in ok @@ KUndip (x, ty, k') @@ -1821,19 +1813,17 @@ let log_next_continuation : | KList_enter_body (body, xs, ys, ty, len, k) -> let k' = instrument_cont logger (Item_t (assert_some ty, stack_ty)) k in ok @@ KList_enter_body (body, xs, ys, ty, len, k') - | KList_exit_body (body, xs, ys, ty, len, k) -> ( - match[@coq_match_with_default] stack_ty with - | Item_t (_, sty) -> - let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in - ok @@ KList_exit_body (body, xs, ys, ty, len, k')) + | KList_exit_body (body, xs, ys, ty, len, k) -> + let (Item_t (_, sty)) = stack_ty in + let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in + ok @@ KList_exit_body (body, xs, ys, ty, len, k') | KMap_enter_body (body, xs, ys, ty, k) -> let k' = instrument_cont logger (Item_t (assert_some ty, stack_ty)) k in ok @@ KMap_enter_body (body, xs, ys, ty, k') - | KMap_exit_body (body, xs, ys, yk, ty, k) -> ( - match[@coq_match_with_default] stack_ty with - | Item_t (_, sty) -> - let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in - ok @@ KMap_exit_body (body, xs, ys, yk, ty, k')) + | KMap_exit_body (body, xs, ys, yk, ty, k) -> + let (Item_t (_, sty)) = stack_ty in + let k' = instrument_cont logger (Item_t (assert_some ty, sty)) k in + ok @@ KMap_exit_body (body, xs, ys, yk, ty, k') | KMap_head (_, _) | KView_exit (_, _) | KLog _ (* This case should never happen. *) | KNil -> @@ -1845,6 +1835,6 @@ let rec dipn_stack_ty : (c, u) stack_ty -> (a, s) stack_ty = fun witness stack -> - match[@coq_match_with_default] (witness, stack) with + match (witness, stack) with | KPrefix (_, _, witness'), Item_t (_, sty) -> dipn_stack_ty witness' sty | KRest, sty -> sty diff --git a/src/proto_alpha/bin_sc_rollup_node/RPC_server.ml b/src/proto_alpha/bin_sc_rollup_node/RPC_server.ml index 983c1ef176cc6..3e72b767f1e65 100644 --- a/src/proto_alpha/bin_sc_rollup_node/RPC_server.ml +++ b/src/proto_alpha/bin_sc_rollup_node/RPC_server.ml @@ -302,7 +302,7 @@ module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct Simulation.end_simulation node_ctxt sim in let num_ticks = Z.(num_ticks_0 + num_ticks_end) in - let*! outbox = PVM.get_outbox inbox_level state in + let*! outbox = assert false in let output = List.filter (fun Sc_rollup.{outbox_level; _} -> outbox_level = inbox_level) diff --git a/src/proto_alpha/bin_sc_rollup_node/arith_pvm.ml b/src/proto_alpha/bin_sc_rollup_node/arith_pvm.ml index 881417dcc1d31..2580a766b9978 100644 --- a/src/proto_alpha/bin_sc_rollup_node/arith_pvm.ml +++ b/src/proto_alpha/bin_sc_rollup_node/arith_pvm.ml @@ -36,7 +36,8 @@ module Arith_proof_format = (struct include Sc_rollup.State_hash - let of_context_hash = Sc_rollup.State_hash.context_hash_to_state_hash + let of_context_hash = + assert false (* Sc_rollup.State_hash.context_hash_to_state_hash *) end) (struct let proof_encoding = diff --git a/src/proto_alpha/bin_sc_rollup_node/wasm_2_0_0_pvm.ml b/src/proto_alpha/bin_sc_rollup_node/wasm_2_0_0_pvm.ml index 45fc6c234f82f..3b7fe5b58d82f 100644 --- a/src/proto_alpha/bin_sc_rollup_node/wasm_2_0_0_pvm.ml +++ b/src/proto_alpha/bin_sc_rollup_node/wasm_2_0_0_pvm.ml @@ -36,7 +36,8 @@ module Wasm_2_0_0_proof_format = (struct include Sc_rollup.State_hash - let of_context_hash = Sc_rollup.State_hash.context_hash_to_state_hash + let of_context_hash = + assert false (* Sc_rollup.State_hash.context_hash_to_state_hash *) end) (struct let proof_encoding = diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml index fe88e14d2fea3..e83fe549ccd95 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml @@ -1215,35 +1215,43 @@ let extract_ir_sized_step : | IList_map (_, _, _, _), _ -> Instructions.list_map | IList_size (_, _), (list, _) -> Instructions.list_size (Size.list list) | IEmpty_set (_, _, _), _ -> Instructions.empty_set - | ISet_iter _, (set, _) -> Instructions.set_iter (Size.set set) + | ISet_iter _, (_, _) -> + assert false (* Instructions.set_iter (Size.set set) *) | ISet_mem (_, _), (v, (set, _)) -> let (module S) = Script_set.get set in - let sz = S.OPS.elt_size v in - Instructions.set_mem sz (Size.set set) + let _ = S.OPS.elt_size v in + assert false + (* Instructions.set_mem sz (Size.set set) *) | ISet_update (_, _), (v, (_flag, (set, _))) -> let (module S) = Script_set.get set in - let sz = S.OPS.elt_size v in - Instructions.set_update sz (Size.set set) + let _ = S.OPS.elt_size v in + assert false + (* Instructions.set_update sz (Size.set set) *) | ISet_size (_, _), (set, _) -> Instructions.set_size (Size.set set) | IEmpty_map (_, _, _, _), _ -> Instructions.empty_map - | IMap_map _, (map, _) -> Instructions.map_map (Size.map map) - | IMap_iter _, (map, _) -> Instructions.map_iter (Size.map map) + | IMap_map _, (_, _) -> assert false (* Instructions.map_map (Size.map map) *) + | IMap_iter _, (_, _) -> + assert false (* Instructions.map_iter (Size.map map) *) | IMap_mem (_, _), (v, (map, _)) -> let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_mem key_size (Size.map map) + let _ = Map.OPS.key_size v in + (* Instructions.map_mem key_size (Size.map map) *) + assert false | IMap_get (_, _), (v, (map, _)) -> let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_get key_size (Size.map map) + let _ = Map.OPS.key_size v in + assert false + (* Instructions.map_get key_size (Size.map map) *) | IMap_update (_, _), (v, (_elt_opt, (map, _))) -> let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_update key_size (Size.map map) + let _ = Map.OPS.key_size v in + assert false + (* Instructions.map_update key_size (Size.map map) *) | IMap_get_and_update (_, _), (v, (_elt_opt, (map, _))) -> let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size v in - Instructions.map_get_and_update key_size (Size.map map) + let _ = Map.OPS.key_size v in + assert false + (* Instructions.map_get_and_update key_size (Size.map map) *) | IMap_size (_, _), (map, _) -> Instructions.map_size (Size.map map) | IEmpty_big_map (_, _, _, _), _ -> Instructions.empty_big_map | IBig_map_mem (_, _), (v, (Big_map {diff = {size; _}; key_type; _}, _)) -> @@ -1516,8 +1524,9 @@ let extract_control_trace (type bef_top bef aft_top aft) Control.map_enter_body (Size.of_int (List.length xs)) | KMap_exit_body (_, _, map, k, _, _) -> let (module Map) = Script_map.get_module map in - let key_size = Map.OPS.key_size k in - Control.map_exit_body key_size (Size.map map) + let _ = Map.OPS.key_size k in + assert false + (* Control.map_exit_body key_size (Size.map map) *) | KView_exit _ -> Control.view_exit | KLog _ -> Control.log diff --git a/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml index 2a1d655260c7d..0472ac9266e00 100644 --- a/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml @@ -205,30 +205,31 @@ module Sc_rollup_add_external_messages_benchmark = struct in let message_length = String.length (message :> string) in - let new_ctxt = - let open Lwt_result_syntax in - let* block, _ = Context.init1 () in - let+ b = Incremental.begin_construction block in - let ctxt = Incremental.alpha_ctxt b in - (* Necessary to originate rollups. *) - let ctxt = - Alpha_context.Origination_nonce.init - ctxt - Tezos_crypto.Operation_hash.zero - in - Alpha_context.Internal_for_tests.to_raw ctxt - in - + (*let new_ctxt = assert false + let open Lwt_result_syntax in + let* block, _ = Context.init1 () in + let+ b = Incremental.begin_construction block in + let ctxt = Incremental.alpha_ctxt b in + (* Necessary to originate rollups. *) + let ctxt = + Alpha_context.Origination_nonce.init + ctxt + Tezos_crypto.Operation_hash.zero + in + Alpha_context.Internal_for_tests.to_raw ctxt + in *) let ctxt_with_rollup = + assert false + (* let open Lwt_result_syntax in let* ctxt = new_ctxt in let {Michelson_v1_parser.expanded; _}, _ = Michelson_v1_parser.parse_expression "unit" in - let parameters_ty = Alpha_context.Script.lazy_expr expanded in + let _ = Alpha_context.Script.lazy_expr expanded in let boot_sector = "" in let kind = Sc_rollups.Kind.Example_arith in - let*! genesis_commitment = + let*! _ = Sc_rollup_helpers.genesis_commitment_raw ~boot_sector ~origination_level:(Raw_context.current_level ctxt).level @@ -242,7 +243,7 @@ module Sc_rollup_add_external_messages_benchmark = struct ~parameters_ty ~genesis_commitment in - (rollup, ctxt) + (rollup, ctxt) *) in let add_message_and_increment_level ctxt = @@ -251,10 +252,23 @@ module Sc_rollup_add_external_messages_benchmark = struct Lwt.map Environment.wrap_tzresult @@ Sc_rollup_inbox_storage.add_external_messages ctxt ["CAFEBABE"] in - let ctxt = Raw_context.Internal_for_tests.add_level ctxt 1 in + let _ctxt = Raw_context.Internal_for_tests.add_level ctxt 1 in + let ctxt = assert false in (inbox, ctxt) in + (* let add_message_and_increment_level ctxt rollup = *) + (* let open Lwt_result_syntax in *) + (* let+ inbox, _, ctxt = *) + (* Lwt.map Environment.wrap_tzresult *) + (* @@ Sc_rollup_inbox_storage.add_external_messages *) + (* ctxt *) + (* rollup *) + (* ["CAFEBABE"] *) + (* in *) + (* let ctxt = Raw_context.Internal_for_tests.add_level ctxt 1 in *) + (* (inbox, ctxt) *) + (* in *) let prepare_benchmark_scenario () = let open Lwt_result_syntax in let rec add_messages_for_level ctxt inbox = diff --git a/src/proto_alpha/lib_benchmarks_proto/storage_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/storage_benchmarks.ml index cffa19ba68747..6650febcb3014 100644 --- a/src/proto_alpha/lib_benchmarks_proto/storage_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/storage_benchmarks.ml @@ -91,13 +91,13 @@ module Int32 = struct module Index = struct type t = int - let path_length = 1 + let path_length = ok 1 let to_path c l = string_of_int c :: l let of_path = function - | [] | _ :: _ :: _ -> None - | [c] -> int_of_string_opt c + | [] | _ :: _ :: _ -> ok None + | [c] -> ok @@ int_of_string_opt c type 'a ipath = 'a * t diff --git a/src/proto_alpha/lib_client/client_proto_rollups.ml b/src/proto_alpha/lib_client/client_proto_rollups.ml index 57811933201b4..48c00b3846898 100644 --- a/src/proto_alpha/lib_client/client_proto_rollups.ml +++ b/src/proto_alpha/lib_client/client_proto_rollups.ml @@ -114,14 +114,16 @@ module ScRollup = struct return (Some p) | None -> return None - let kinded_hash_to_state_hash = function - | `Value hash | `Node hash -> - Sc_rollup.State_hash.context_hash_to_state_hash hash + (* let kinded_hash_to_state_hash _ = assert false *) + (* function *) + (* | `Value hash | `Node hash -> *) + (* Sc_rollup.State_hash.context_hash_to_state_hash hash *) - let proof_before proof = - kinded_hash_to_state_hash proof.Context.Proof.before + let proof_before _ = assert false + (* kinded_hash_to_state_hash proof.Context.Proof.before *) - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after + (* let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after *) + let proof_after _ = assert false let proof_encoding = Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V2.Tree32 diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 3c6682170db8b..add677959e895 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -2912,21 +2912,21 @@ let estimated_time round_durations ~current_level ~current_round Timestamp.(round_start_at_next_level +? delay) >>? fun timestamp -> Result.return_some timestamp -let requested_levels ~default_level ctxt cycles levels = +let requested_levels ~default_level _ cycles levels = match (levels, cycles) with | [], [] -> [default_level] - | levels, cycles -> - (* explicitly fail when requested levels or cycle are in the past... - or too far in the future... - TODO: https://gitlab.com/tezos/tezos/-/issues/2335 - this old comment (from version Alpha) conflicts with - the specification of the RPCs that use this code. - *) - List.sort_uniq - Level.compare - (List.rev_append - (List.rev_map (Level.from_raw ctxt) levels) - (List.concat_map (Level.levels_in_cycle ctxt) cycles)) + | _, _ -> [default_level] +(* explicitly fail when requested levels or cycle are in the past... + or too far in the future... + TODO: https://gitlab.com/tezos/tezos/-/issues/2335 + this old comment (from version Alpha) conflicts with + the specification of the RPCs that use this code. +*) +(* List.sort_uniq *) +(* Level.compare *) +(* (List.rev_append *) +(* (List.rev_map (Level.from_raw ctxt) levels) *) +(* (List.concat_map (Level.levels_in_cycle ctxt) cycles)) *) module Baking_rights = struct type t = { @@ -3064,7 +3064,8 @@ module Baking_rights = struct ([], Tezos_crypto.Signature.Public_key_hash.Set.empty) rights - let register () = + let register () = assert false + (* Registration.register0 ~chunked:true S.baking_rights (fun ctxt q () -> let cycles = match q.cycle with None -> [] | Some cycle -> [cycle] in let levels = @@ -3114,6 +3115,7 @@ module Baking_rights = struct List.filter is_requested rights in rights) + *) let get ctxt ?(levels = []) ?cycle ?(delegates = []) ?(consensus_keys = []) ?(all = false) ?max_round block = @@ -3458,7 +3460,7 @@ let register () = Parse.register () ; Contract.register () ; Big_map.register () ; - Baking_rights.register () ; + (* Baking_rights.register () ; *) Endorsing_rights.register () ; Validators.register () ; Sc_rollup.register () ; @@ -3476,7 +3478,10 @@ let register () = ~chunked:true S.levels_in_current_cycle (fun ctxt q () -> - let rev_levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in + let open Lwt_result_syntax in + let*? rev_levels = + Level.levels_in_current_cycle ctxt ~offset:q.offset () + in match rev_levels with | [] -> return_none | [level] -> return (Some (level.level, level.level)) diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index b679da82972d5..ce2b6d741e09b 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -2,6 +2,7 @@ "expected_env_version": 8, "hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK", "modules": [ + "Internal_errors", "Misc", "Non_empty_string", "Path_encoding", diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 2ae2861e72074..c76280f0bcea8 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -584,15 +584,17 @@ let prepare ctxt ~level ~predecessor_timestamp ~timestamp = return (ctxt, balance_updates, origination_results) let finalize ?commit_message:message c fitness = + let open Result_syntax in + let* last_allowed_fork_level = Level.last_allowed_fork_level c in let context = Raw_context.recover c in - { - Updater.context; - fitness; - message; - max_operations_ttl = (Raw_context.constants c).max_operations_time_to_live; - last_allowed_fork_level = - Raw_level.to_int32 @@ Level.last_allowed_fork_level c; - } + return + { + Updater.context; + fitness; + message; + max_operations_ttl = (Raw_context.constants c).max_operations_time_to_live; + last_allowed_fork_level = Raw_level.to_int32 last_allowed_fork_level; + } let current_context c = Raw_context.recover c diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index c923feb0d2181..3f6e13b52195b 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -260,9 +260,9 @@ module Cycle : sig val pred : cycle -> cycle option - val add : cycle -> int -> cycle + val add : cycle -> int -> cycle tzresult - val sub : cycle -> int -> cycle option + val sub : cycle -> int -> cycle option tzresult val to_int32 : cycle -> int32 @@ -1148,37 +1148,38 @@ module Level : sig type level = t - val root : context -> level + val root : context -> level tzresult - val succ : context -> level -> level + val succ : context -> level -> level tzresult - val pred : context -> level -> level option + val pred : context -> level -> level option tzresult - val from_raw : context -> Raw_level.t -> level + val from_raw : context -> Raw_level.t -> level tzresult (** Fails with [Negative_level_and_offset_sum] if the sum of the raw_level and the offset is negative. *) val from_raw_with_offset : context -> offset:int32 -> Raw_level.t -> level tzresult (** [add c level i] i must be positive *) - val add : context -> level -> int -> level + val add : context -> level -> int -> level tzresult (** [sub c level i] i must be positive *) - val sub : context -> level -> int -> level option + val sub : context -> level -> int -> level option tzresult val diff : level -> level -> int32 val current : context -> level - val last_level_in_cycle : context -> Cycle.t -> level + val last_level_in_cycle : context -> Cycle.t -> level tzresult - val levels_in_cycle : context -> Cycle.t -> level list + val levels_in_cycle : context -> Cycle.t -> level list tzresult - val levels_in_current_cycle : context -> ?offset:int32 -> unit -> level list + val levels_in_current_cycle : + context -> ?offset:int32 -> unit -> level list tzresult - val last_allowed_fork_level : context -> Raw_level.t + val last_allowed_fork_level : context -> Raw_level.t tzresult - val dawn_of_a_new_cycle : context -> Cycle.t option + val dawn_of_a_new_cycle : context -> Cycle.t option tzresult val may_snapshot_stake_distribution : context -> bool @@ -1661,7 +1662,7 @@ module Contract : sig val must_be_allocated : context -> t -> unit tzresult Lwt.t - val list : context -> t list Lwt.t + val list : context -> t list tzresult Lwt.t (** Functions related to both implicit accounts and originated contracts. *) @@ -2375,8 +2376,8 @@ module Bond_id : sig Contract.t -> order:[`Sorted | `Undefined] -> init:'a -> - f:(t -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(t -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t end end @@ -2647,10 +2648,10 @@ module Delegate : sig context -> order:[`Sorted | `Undefined] -> init:'a -> - f:(public_key_hash -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(public_key_hash -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t - val list : context -> public_key_hash list Lwt.t + val list : context -> public_key_hash list tzresult Lwt.t val drain : context -> @@ -2722,7 +2723,8 @@ module Delegate : sig val staking_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t (** See {!Contract_delegate_storage.delegated_contracts}. *) - val delegated_contracts : context -> public_key_hash -> Contract.t list Lwt.t + val delegated_contracts : + context -> public_key_hash -> Contract.t list tzresult Lwt.t val delegated_balance : context -> public_key_hash -> Tez.t tzresult Lwt.t @@ -2822,7 +2824,7 @@ module Vote : sig val get_proposals : context -> int64 Protocol_hash.Map.t tzresult Lwt.t - val clear_proposals : context -> context Lwt.t + val clear_proposals : context -> context tzresult Lwt.t val listings_encoding : (public_key_hash * int64) list Data_encoding.t @@ -2830,7 +2832,7 @@ module Vote : sig val in_listings : context -> public_key_hash -> bool Lwt.t - val get_listings : context -> (public_key_hash * int64) list Lwt.t + val get_listings : context -> (public_key_hash * int64) list tzresult Lwt.t type ballot = Yay | Nay | Pass @@ -2884,9 +2886,10 @@ module Vote : sig val get_ballots : context -> ballots tzresult Lwt.t - val get_ballot_list : context -> (public_key_hash * ballot) list Lwt.t + val get_ballot_list : + context -> (public_key_hash * ballot) list tzresult Lwt.t - val clear_ballots : context -> context Lwt.t + val clear_ballots : context -> context tzresult Lwt.t val get_current_quorum : context -> int32 tzresult Lwt.t @@ -3167,7 +3170,7 @@ module Sc_rollup : sig module State_hash : sig include S.HASH with type t = Sc_rollup_repr.State_hash.t - val context_hash_to_state_hash : Context_hash.t -> t + val context_hash_to_state_hash : Context_hash.t -> t tzresult type unreachable = | @@ -3750,7 +3753,9 @@ module Sc_rollup : sig val hash : context -> t -> (context * Hash.t) tzresult val genesis_commitment : - origination_level:Raw_level.t -> genesis_state_hash:State_hash.t -> t + origination_level:Raw_level.t -> + genesis_state_hash:State_hash.t -> + t tzresult type genesis_info = {level : Raw_level.t; commitment_hash : Hash.t} @@ -4292,7 +4297,7 @@ module Cache : sig val find : context -> identifier -> cached_value option tzresult Lwt.t - val list_identifiers : context -> (string * int) list + val list_identifiers : context -> (string * int) list tzresult val identifier_rank : context -> string -> int option @@ -5080,7 +5085,10 @@ val dictator_proposal_seen : t -> bool (** Finalize an {{!t} [Alpha_context.t]}, producing a [validation_result]. *) val finalize : - ?commit_message:string -> context -> Fitness.raw -> Updater.validation_result + ?commit_message:string -> + context -> + Fitness.raw -> + Updater.validation_result tzresult (** Should only be used by [Main.current_context] to return a context usable for RPCs *) val current_context : context -> Context.t diff --git a/src/proto_alpha/lib_protocol/alpha_services.ml b/src/proto_alpha/lib_protocol/alpha_services.ml index b2f703214956b..7ea1f3845527e 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.ml +++ b/src/proto_alpha/lib_protocol/alpha_services.ml @@ -138,8 +138,9 @@ module Nonce = struct let register () = let open Services_registration in + let open Lwt_result_syntax in register1 ~chunked:false S.get (fun ctxt raw_level () () -> - let level = Level.from_raw ctxt raw_level in + let*? level = Level.from_raw ctxt raw_level in Nonce.get ctxt level >|= function | Ok (Revealed nonce) -> ok (Revealed nonce) | Ok (Unrevealed {nonce_hash; _}) -> ok (Missing nonce_hash) diff --git a/src/proto_alpha/lib_protocol/amendment.ml b/src/proto_alpha/lib_protocol/amendment.ml index 64bc8c852cd5f..0a36707ddde13 100644 --- a/src/proto_alpha/lib_protocol/amendment.ml +++ b/src/proto_alpha/lib_protocol/amendment.ml @@ -98,7 +98,7 @@ let get_approval_and_update_participation_ema ctxt = Vote.get_total_voting_power_free ctxt >>=? fun maximum_vote -> Vote.get_participation_ema ctxt >>=? fun participation_ema -> Vote.get_current_quorum ctxt >>=? fun expected_quorum -> - Vote.clear_ballots ctxt >>= fun ctxt -> + Vote.clear_ballots ctxt >>=? fun ctxt -> let approval, new_participation_ema = approval_and_participation_ema ballots @@ -120,7 +120,7 @@ let start_new_voting_period ctxt = (match kind with | Proposal -> ( select_winning_proposal ctxt >>=? fun proposal -> - Vote.clear_proposals ctxt >>= fun ctxt -> + Vote.clear_proposals ctxt >>=? fun ctxt -> match proposal with | None -> Voting_period.reset ctxt | Some proposal -> @@ -169,8 +169,8 @@ let is_testnet_dictator ctxt chain_id delegate = mainnet: see {!is_testnet_dictator}. *) let apply_testnet_dictator_proposals ctxt chain_id proposals = let open Lwt_result_syntax in - let*! ctxt = Vote.clear_ballots ctxt in - let*! ctxt = Vote.clear_proposals ctxt in + let* ctxt = Vote.clear_ballots ctxt in + let* ctxt = Vote.clear_proposals ctxt in let*! ctxt = Vote.clear_current_proposal ctxt in let ctxt = record_dictator_proposal_seen ctxt in match proposals with diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 7b1193e843e09..b3e8299a97437 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -2045,13 +2045,13 @@ let record_operation (type kind) ctxt hash (operation : kind operation) : let record_preendorsement ctxt (mode : mode) (content : consensus_content) : (context * Kind.preendorsement contents_result_list) tzresult = let open Result_syntax in - let ctxt = + let* ctxt = match mode with | Full_construction _ -> ( match Consensus.get_preendorsements_quorum_round ctxt with | None -> Consensus.set_preendorsements_quorum_round ctxt content.round - | Some _ -> ctxt) - | Application _ | Partial_construction _ -> ctxt + | Some _ -> return ctxt) + | Application _ | Partial_construction _ -> return ctxt in match Slot.Map.find content.slot (Consensus.allowed_preendorsements ctxt) with | None -> @@ -2097,7 +2097,7 @@ let record_endorsement ctxt (mode : mode) (content : consensus_content) : }) in if is_grandparent_endorsement mode content then - let level = Level.from_raw ctxt content.level in + let*? level = Level.from_raw ctxt content.level in let* ctxt, ({delegate; _} as consensus_key) = Stake_distribution.slot_owner ctxt level content.slot in @@ -2170,6 +2170,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt * kind Kind.double_consensus_operation_evidence contents_result_list) tzresult Lwt.t = + let open Lwt_result_syntax in let mk_result (balance_updates : Receipt.balance_updates) : kind Kind.double_consensus_operation_evidence contents_result = match[@coq_match_with_default] op1.protocol_data.contents with @@ -2180,7 +2181,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt in match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement e1) | Single (Endorsement e1) -> - let level = Level.from_raw ctxt e1.level in + let*? level = Level.from_raw ctxt e1.level in Stake_distribution.slot_owner ctxt level e1.slot >>=? fun (ctxt, consensus_pk1) -> punish_delegate @@ -2192,10 +2193,11 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~payload_producer let punish_double_baking ctxt (bh1 : Block_header.t) ~payload_producer = + let open Lwt_result_syntax in Fitness.from_raw bh1.shell.fitness >>?= fun bh1_fitness -> let round1 = Fitness.round bh1_fitness in Raw_level.of_int32 bh1.shell.level >>?= fun raw_level -> - let level = Level.from_raw ctxt raw_level in + let*? level = Level.from_raw ctxt raw_level in let committee_size = Constants.consensus_committee_size ctxt in Round.to_slot round1 ~committee_size >>?= fun slot1 -> Stake_distribution.slot_owner ctxt level slot1 @@ -2211,6 +2213,7 @@ let punish_double_baking ctxt (bh1 : Block_header.t) ~payload_producer = let apply_contents_list (type kind) ctxt chain_id (mode : mode) ~payload_producer (contents_list : kind contents_list) : (context * kind contents_result_list) tzresult Lwt.t = + let open Lwt_result_syntax in let mempool_mode = match mode with | Partial_construction _ -> true @@ -2236,7 +2239,7 @@ let apply_contents_list (type kind) ctxt chain_id (mode : mode) return (ctxt, Single_result (Dal_attestation_result {delegate = op.attestor})) | Single (Seed_nonce_revelation {level; nonce}) -> - let level = Level.from_raw ctxt level in + let*? level = Level.from_raw ctxt level in Nonce.reveal ctxt level nonce >>=? fun ctxt -> let tip = Constants.seed_nonce_revelation_tip ctxt in let contract = @@ -2361,7 +2364,9 @@ let apply_operation application_state operation_hash operation = ~payload_producer:Consensus_key.zero let may_start_new_cycle ctxt = - match Level.dawn_of_a_new_cycle ctxt with + let open Lwt_result_syntax in + let*? dawn = Level.dawn_of_a_new_cycle ctxt in + match dawn with | None -> return (ctxt, [], []) | Some last_cycle -> Delegate.cycle_end ctxt last_cycle @@ -2558,7 +2563,7 @@ let begin_application ctxt chain_id ~migration_balance_updates let level = block_header.shell.level in let*? predecessor_round = Fitness.round_from_raw predecessor_fitness in let*? predecessor_level = Raw_level.of_int32 (Int32.pred level) in - let predecessor_level = Level.from_raw ctxt predecessor_level in + let*? predecessor_level = Level.from_raw ctxt predecessor_level in let round = Fitness.round fitness in let current_level = Level.current ctxt in let* ctxt, _slot, block_producer = @@ -2827,8 +2832,8 @@ let () = (fun () -> Missing_shell_header) let finalize_with_commit_message ctxt ~cache_nonce fitness round op_count = - let open Lwt_syntax in - let* ctxt = Cache.Admin.sync ctxt cache_nonce in + let open Lwt_result_syntax in + let*! ctxt = Cache.Admin.sync ctxt cache_nonce in let raw_level = Raw_level.to_int32 (Level.current ctxt).level in let commit_message = Format.asprintf @@ -2840,7 +2845,7 @@ let finalize_with_commit_message ctxt ~cache_nonce fitness round op_count = round op_count in - let validation_result = + let*? validation_result = finalize ~commit_message ctxt (Fitness.to_raw fitness) in return validation_result @@ -2903,14 +2908,14 @@ let finalize_block (application_state : application_state) shell_header_opt = ~block_producer ~payload_producer in - let*! result = + let* result = finalize_with_commit_message ctxt ~cache_nonce fitness round op_count in return (result, receipt) | Partial_construction {predecessor_fitness; _} -> let* voting_period_info = Voting_period.get_rpc_current_info ctxt in let level_info = Level.current ctxt in - let result = finalize ctxt predecessor_fitness in + let*? result = finalize ctxt predecessor_fitness in return ( result, Apply_results. @@ -2951,7 +2956,7 @@ let finalize_block (application_state : application_state) shell_header_opt = ~block_producer ~payload_producer in - let*! result = + let* result = finalize_with_commit_message ctxt ~cache_nonce fitness round op_count in return (result, receipt) diff --git a/src/proto_alpha/lib_protocol/bond_id_repr.ml b/src/proto_alpha/lib_protocol/bond_id_repr.ml index b00e6e59275be..bed13cb8f5e9e 100644 --- a/src/proto_alpha/lib_protocol/bond_id_repr.ml +++ b/src/proto_alpha/lib_protocol/bond_id_repr.ml @@ -107,19 +107,20 @@ end module Index = struct type nonrec t = t - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in let (`Hex key) = Hex.of_bytes raw_key in key :: l - let of_path = function + let of_path : _ -> _ tzresult = function | [key] -> - Option.bind - (Hex.to_bytes (`Hex key)) - (Data_encoding.Binary.of_bytes_opt encoding) - | _ -> None + ok + @@ Option.bind + (Hex.to_bytes (`Hex key)) + (Data_encoding.Binary.of_bytes_opt encoding) + | _ -> ok None let rpc_arg = rpc_arg diff --git a/src/proto_alpha/lib_protocol/bounded_history_repr.ml b/src/proto_alpha/lib_protocol/bounded_history_repr.ml index fe315b0ee73f4..24120d3477ecb 100644 --- a/src/proto_alpha/lib_protocol/bounded_history_repr.ml +++ b/src/proto_alpha/lib_protocol/bounded_history_repr.ml @@ -242,7 +242,7 @@ module Make (Name : NAME) (Key : KEY) (Value : VALUE) : | None -> (* If t.size > t.capacity > 0, there is necessarily an entry whose index is t.oldest_index in [sequence]. *) - assert false + error Internal_errors.Asserted | Some h -> let sequence = Int64_map.remove l t.sequence in let events = Map.remove h events in diff --git a/src/proto_alpha/lib_protocol/cache_repr.ml b/src/proto_alpha/lib_protocol/cache_repr.ml index e0832828d10fc..a6794fa438bf1 100644 --- a/src/proto_alpha/lib_protocol/cache_repr.ml +++ b/src/proto_alpha/lib_protocol/cache_repr.ml @@ -84,18 +84,20 @@ let string_of_internal_identifier {namespace; id} = namespace ^ String.make 1 separator ^ id let internal_identifier_of_string raw = + let open Result_syntax in match String.index_opt raw separator with - | None -> assert false + | None -> error Internal_errors.Asserted | Some index -> - { - (* We do not need to call sanitize here since we stop at the first '@' - from index 0. It is a guarantee that there is no '@' between 0 and - (index - 1 ). *) - namespace = String.sub raw 0 index; - id = - (let delim_idx = index + 1 in - String.sub raw delim_idx (String.length raw - delim_idx)); - } + return + { + (* We do not need to call sanitize here since we stop at the first '@' + from index 0. It is a guarantee that there is no '@' between 0 and + (index - 1 ). *) + namespace = String.sub raw 0 index; + id = + (let delim_idx = index + 1 in + String.sub raw delim_idx (String.length raw - delim_idx)); + } let internal_identifier_of_key key = let raw = Raw_context.Cache.identifier_of_key key in @@ -180,11 +182,12 @@ module Admin = struct let key_rank context key = Raw_context.Cache.key_rank context key let value_of_key ctxt key = + let open Lwt_result_syntax in (* [value_of_key] is a maintenance operation: it is typically run when a node reboots. For this reason, this operation is not carbonated. *) let ctxt = Raw_context.set_gas_unlimited ctxt in - let {namespace; id} = internal_identifier_of_key key in + let*? {namespace; id} = internal_identifier_of_key key in match NamespaceMap.find namespace !value_of_key_handlers with | Some value_of_key -> value_of_key ctxt id | None -> @@ -214,7 +217,7 @@ module type INTERFACE = sig val find : Raw_context.t -> identifier -> cached_value option tzresult Lwt.t - val list_identifiers : Raw_context.t -> (identifier * int) list + val list_identifiers : Raw_context.t -> (identifier * int) list tzresult val identifier_rank : Raw_context.t -> identifier -> int option @@ -261,6 +264,7 @@ let register_exn (type cvalue) Admin.update ctxt (mk ~id) v let find ctxt id = + let open Lwt_result_syntax in let cache_size_in_bytes = size ctxt in Raw_context.consume_gas ctxt (Cache_costs.cache_find ~cache_size_in_bytes) >>?= fun ctxt -> @@ -276,20 +280,28 @@ let register_exn (type cvalue) environment in exchange for extra complexity. The argument that justifies this [assert false] seems simple enough to keep the current design though. *) - assert false) + Lwt.return @@ error Internal_errors.Asserted) let list_identifiers ctxt = + let open Result_syntax in Admin.list_keys ctxt ~cache_index:C.cache_index |> function | None -> (* `cache_index` is valid. *) - assert false + error Internal_errors.Asserted | Some list -> - List.filter_map - (fun (key, age) -> - let {namespace; id} = internal_identifier_of_key key in - if String.equal namespace C.namespace then Some (id, age) - else None) - list + let* list = + List.map_e + (fun (key, age) -> + let* res = internal_identifier_of_key key in + return (res, age)) + list + in + return + (List.filter_map + (fun ({namespace; id}, age) -> + if String.equal namespace C.namespace then Some (id, age) + else None) + list) let identifier_rank ctxt id = Admin.key_rank ctxt (mk ~id) end) diff --git a/src/proto_alpha/lib_protocol/cache_repr.mli b/src/proto_alpha/lib_protocol/cache_repr.mli index 2d026d4236018..a243503cd9690 100644 --- a/src/proto_alpha/lib_protocol/cache_repr.mli +++ b/src/proto_alpha/lib_protocol/cache_repr.mli @@ -214,7 +214,7 @@ module type INTERFACE = sig identifiers of the cached values along with their respective size. The returned list is sorted in terms of their age in the cache, the oldest coming first. *) - val list_identifiers : Raw_context.t -> (string * int) list + val list_identifiers : Raw_context.t -> (string * int) list tzresult (** [identifier_rank ctxt identifier] returns the number of cached values older than the one of [identifier]; or, [None] if the [identifier] has diff --git a/src/proto_alpha/lib_protocol/contract_delegate_storage.mli b/src/proto_alpha/lib_protocol/contract_delegate_storage.mli index 189a03df8fdf1..0bf13530c70a6 100644 --- a/src/proto_alpha/lib_protocol/contract_delegate_storage.mli +++ b/src/proto_alpha/lib_protocol/contract_delegate_storage.mli @@ -70,4 +70,6 @@ val set : (** [delegated_contracts ctxt delegate] returns the list of contracts (implicit or originated) that delegated to [delegate]. *) val delegated_contracts : - Raw_context.t -> Signature.Public_key_hash.t -> Contract_repr.t list Lwt.t + Raw_context.t -> + Signature.Public_key_hash.t -> + Contract_repr.t list tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/contract_repr.ml b/src/proto_alpha/lib_protocol/contract_repr.ml index e1073e1253d94..10f0549eef7ab 100644 --- a/src/proto_alpha/lib_protocol/contract_repr.ml +++ b/src/proto_alpha/lib_protocol/contract_repr.ml @@ -181,7 +181,10 @@ let originated_contracts ~until: (Origination_nonce.{origination_index = last; operation_hash = last_hash} as origination_nonce) = - assert (Operation_hash.equal first_hash last_hash) ; + let open Result_syntax in + let* _ = + Internal_errors.do_assert (Operation_hash.equal first_hash last_hash) + in let[@coq_struct "origination_index"] rec contracts acc origination_index = if Compare.Int32.(origination_index < first) then acc else @@ -189,7 +192,7 @@ let originated_contracts let acc = Contract_hash.of_nonce origination_nonce :: acc in contracts acc (Int32.pred origination_index) in - contracts [] (Int32.pred last) + return (contracts [] (Int32.pred last)) let rpc_arg = let construct = to_b58check in @@ -206,19 +209,20 @@ let rpc_arg = module Index = struct type nonrec t = t - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in let (`Hex key) = Hex.of_bytes raw_key in key :: l - let of_path = function + let of_path : _ -> _ tzresult = function | [key] -> - Option.bind - (Hex.to_bytes (`Hex key)) - (Data_encoding.Binary.of_bytes_opt encoding) - | _ -> None + ok + @@ Option.bind + (Hex.to_bytes (`Hex key)) + (Data_encoding.Binary.of_bytes_opt encoding) + | _ -> ok None let rpc_arg = rpc_arg diff --git a/src/proto_alpha/lib_protocol/contract_repr.mli b/src/proto_alpha/lib_protocol/contract_repr.mli index 61d57acf48a1e..9099e69690166 100644 --- a/src/proto_alpha/lib_protocol/contract_repr.mli +++ b/src/proto_alpha/lib_protocol/contract_repr.mli @@ -57,7 +57,9 @@ val originated_contract : Origination_nonce.t -> t must be the same or it will fail with an [assert]. [since] < [until] or the returned list is empty *) val originated_contracts : - since:Origination_nonce.t -> until:Origination_nonce.t -> Contract_hash.t list + since:Origination_nonce.t -> + until:Origination_nonce.t -> + Contract_hash.t list tzresult (** {2 Human readable notation} *) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 8ee48102d0b57..5c95385fc5151 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -294,7 +294,7 @@ end let register () = let open Services_registration in - register0 ~chunked:true S.list (fun ctxt () () -> Contract.list ctxt >|= ok) ; + register0 ~chunked:true S.list (fun ctxt () () -> Contract.list ctxt) ; let register_field_gen ~filter_contract ~wrap_result ~chunked s f = opt_register1 ~chunked s (fun ctxt contract () () -> filter_contract contract @@ fun filtered_contract -> diff --git a/src/proto_alpha/lib_protocol/contract_storage.ml b/src/proto_alpha/lib_protocol/contract_storage.ml index f82d7e1b7ddab..db93f8451c335 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.ml +++ b/src/proto_alpha/lib_protocol/contract_storage.ml @@ -300,6 +300,7 @@ module Legacy_big_map_diff = struct let encoding = Data_encoding.list item_encoding let to_lazy_storage_diff legacy_diffs = + let open Result_syntax in let rev_head (diffs : (_ * (_, _, _) Lazy_storage_diff.diff) list) = match diffs with | [] -> [] @@ -311,27 +312,31 @@ module Legacy_big_map_diff = struct Updates are collected one by one, in reverse order, on the head diff item. So only and exactly the head diff item has its updates reversed. *) - List.fold_left + List.fold_left_e (fun (new_diff : (_ * (_, _, _) Lazy_storage_diff.diff) list) item -> match item with - | Clear id -> (id, Lazy_storage_diff.Remove) :: rev_head new_diff + | Clear id -> + return @@ ((id, Lazy_storage_diff.Remove) :: rev_head new_diff) | Copy {src; dst} -> let src = Lazy_storage_kind.Big_map.Id .of_legacy_USE_ONLY_IN_Legacy_big_map_diff src in - (dst, Lazy_storage_diff.Update {init = Copy {src}; updates = []}) - :: rev_head new_diff + return + @@ (dst, Lazy_storage_diff.Update {init = Copy {src}; updates = []}) + :: rev_head new_diff | Alloc {big_map; key_type; value_type} -> - ( big_map, - Lazy_storage_diff.( - Update - { - init = Alloc Lazy_storage_kind.Big_map.{key_type; value_type}; - updates = []; - }) ) - :: rev_head new_diff + return + @@ ( big_map, + Lazy_storage_diff.( + Update + { + init = + Alloc Lazy_storage_kind.Big_map.{key_type; value_type}; + updates = []; + }) ) + :: rev_head new_diff | Update { big_map; @@ -341,33 +346,34 @@ module Legacy_big_map_diff = struct } -> ( match new_diff with | (id, diff) :: rest when Compare.Z.(id = big_map) -> - let diff = + let* diff = match diff with - | Remove -> assert false + | Remove -> error Internal_errors.Asserted | Update {init; updates} -> let updates = Lazy_storage_kind.Big_map.{key; key_hash; value} :: updates in - Lazy_storage_diff.Update {init; updates} + return @@ Lazy_storage_diff.Update {init; updates} in - (id, diff) :: rest + return @@ ((id, diff) :: rest) | new_diff -> let updates = [Lazy_storage_kind.Big_map.{key; key_hash; value}] in - (big_map, Update {init = Existing; updates}) - :: rev_head new_diff)) + Ok + ((big_map, Update {init = Existing; updates}) + :: rev_head new_diff))) [] legacy_diffs - |> rev_head - |> List.rev_map (fun (id, diff) -> - let id = - Lazy_storage_kind.Big_map.Id - .of_legacy_USE_ONLY_IN_Legacy_big_map_diff - id - in - Lazy_storage_diff.make Lazy_storage_kind.Big_map id diff) + >|? rev_head + >|? List.rev_map (fun (id, diff) -> + let id = + Lazy_storage_kind.Big_map.Id + .of_legacy_USE_ONLY_IN_Legacy_big_map_diff + id + in + Lazy_storage_diff.make Lazy_storage_kind.Big_map id diff) let of_lazy_storage_diff diffs = List.fold_left @@ -438,12 +444,16 @@ let raw_originate c ~prepaid_bootstrap_storage let total_size = Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) lazy_storage_size in - assert (Compare.Z.(total_size >= Z.zero)) ; - let prepaid_bootstrap_storage = - if prepaid_bootstrap_storage then total_size else Z.zero - in - Storage.Contract.Paid_storage_space.init c contract prepaid_bootstrap_storage - >>=? fun c -> Storage.Contract.Used_storage_space.init c contract total_size + if Compare.Z.(total_size >= Z.zero) then + let prepaid_bootstrap_storage = + if prepaid_bootstrap_storage then total_size else Z.zero + in + Storage.Contract.Paid_storage_space.init + c + contract + prepaid_bootstrap_storage + >>=? fun c -> Storage.Contract.Used_storage_space.init c contract total_size + else Lwt.return @@ error Internal_errors.Asserted let create_implicit c manager ~balance = let contract = Contract_repr.Implicit manager in @@ -504,9 +514,10 @@ let fresh_contract_from_current_nonce c = let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until = Raw_context.get_origination_nonce ctxt_since >>?= fun since -> Raw_context.get_origination_nonce ctxt_until >>?= fun until -> + Contract_repr.originated_contracts ~since ~until >>?= fun ocs -> List.filter_s (fun contract -> exists ctxt_until (Contract_repr.Originated contract)) - (Contract_repr.originated_contracts ~since ~until) + ocs >|= ok let check_counter_increment c manager counter = diff --git a/src/proto_alpha/lib_protocol/contract_storage.mli b/src/proto_alpha/lib_protocol/contract_storage.mli index 23c062aad53bf..b57ab3c49eae3 100644 --- a/src/proto_alpha/lib_protocol/contract_storage.mli +++ b/src/proto_alpha/lib_protocol/contract_storage.mli @@ -77,7 +77,7 @@ val must_exist : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t contract is implicit. *) val must_be_allocated : Raw_context.t -> Contract_repr.t -> unit tzresult Lwt.t -val list : Raw_context.t -> Contract_repr.t list Lwt.t +val list : Raw_context.t -> Contract_repr.t list tzresult Lwt.t val check_counter_increment : Raw_context.t -> @@ -149,7 +149,7 @@ module Legacy_big_map_diff : sig val encoding : t Data_encoding.t - val to_lazy_storage_diff : t -> Lazy_storage_diff.diffs + val to_lazy_storage_diff : t -> Lazy_storage_diff.diffs tzresult val of_lazy_storage_diff : Lazy_storage_diff.diffs -> t end @@ -299,8 +299,8 @@ val fold_on_bond_ids : Contract_repr.t -> order:[`Sorted | `Undefined] -> init:'a -> - f:(Bond_id_repr.t -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(Bond_id_repr.t -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t (** [ensure_deallocated_if_empty ctxt contract] de-allocates [contract] if its full balance is zero, and it does not delegate. *) diff --git a/src/proto_alpha/lib_protocol/cycle_repr.ml b/src/proto_alpha/lib_protocol/cycle_repr.ml index b1a4b8bc6e0b9..bbba98ec42b45 100644 --- a/src/proto_alpha/lib_protocol/cycle_repr.ml +++ b/src/proto_alpha/lib_protocol/cycle_repr.ml @@ -45,13 +45,14 @@ let succ = Int32.succ let pred = function 0l -> None | i -> Some (Int32.pred i) let add c i = - assert (Compare.Int.(i >= 0)) ; - Int32.add c (Int32.of_int i) + if Compare.Int.(i >= 0) then Ok (Int32.add c (Int32.of_int i)) + else error Internal_errors.Asserted let sub c i = - assert (Compare.Int.(i >= 0)) ; - let r = Int32.sub c (Int32.of_int i) in - if Compare.Int32.(r < 0l) then None else Some r + if Compare.Int.(i >= 0) then + let r = Int32.sub c (Int32.of_int i) in + if Compare.Int32.(r < 0l) then Ok None else Ok (Some r) + else error Internal_errors.Asserted let diff = Int32.sub @@ -71,11 +72,13 @@ let ( ---> ) = Misc.( ---> ) module Index = struct type t = cycle - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = Int32.to_string (to_int32 c) :: l - let of_path = function [s] -> Int32.of_string_opt s | _ -> None + let of_path : _ -> _ tzresult = function + | [s] -> ok @@ Int32.of_string_opt s + | _ -> ok None let rpc_arg = rpc_arg diff --git a/src/proto_alpha/lib_protocol/cycle_repr.mli b/src/proto_alpha/lib_protocol/cycle_repr.mli index 7ff7a730bb827..74434593d071c 100644 --- a/src/proto_alpha/lib_protocol/cycle_repr.mli +++ b/src/proto_alpha/lib_protocol/cycle_repr.mli @@ -44,9 +44,9 @@ val root : cycle val pred : cycle -> cycle option -val add : cycle -> int -> cycle +val add : cycle -> int -> cycle tzresult -val sub : cycle -> int -> cycle option +val sub : cycle -> int -> cycle option tzresult val succ : cycle -> cycle diff --git a/src/proto_alpha/lib_protocol/dal_services.ml b/src/proto_alpha/lib_protocol/dal_services.ml index 660f6783ec7ff..be3b9d7574fc8 100644 --- a/src/proto_alpha/lib_protocol/dal_services.ml +++ b/src/proto_alpha/lib_protocol/dal_services.ml @@ -36,7 +36,7 @@ let shards ctxt ~level = let open Lwt_result_syntax in let open Dal.Attestation in assert_dal_feature_enabled ctxt >>?= fun () -> - let level = Level.from_raw ctxt level in + let*? level = Level.from_raw ctxt level in let pkh_from_tenderbake_slot slot = Stake_distribution.slot_owner ctxt level slot >|=? fun (ctxt, consensus_key) -> (ctxt, consensus_key.delegate) diff --git a/src/proto_alpha/lib_protocol/dal_slot_storage.ml b/src/proto_alpha/lib_protocol/dal_slot_storage.ml index d271b3cf228e3..d4bc91bd9fd3b 100644 --- a/src/proto_alpha/lib_protocol/dal_slot_storage.ml +++ b/src/proto_alpha/lib_protocol/dal_slot_storage.ml @@ -63,7 +63,9 @@ let update_skip_list ctxt ~confirmed_slot_headers = let finalize_pending_slot_headers ctxt = let {Level_repr.level = raw_level; _} = Raw_context.current_level ctxt in let Constants_parametric_repr.{dal; _} = Raw_context.constants ctxt in - match Raw_level_repr.(sub raw_level dal.attestation_lag) with + let open Lwt_result_syntax in + let*? level_attested = Raw_level_repr.(sub raw_level dal.attestation_lag) in + match level_attested with | None -> return (ctxt, Dal_attestation_repr.empty) | Some level_attested -> ( Storage.Dal.Slot.Headers.find ctxt level_attested >>=? function diff --git a/src/proto_alpha/lib_protocol/delegate_activation_storage.ml b/src/proto_alpha/lib_protocol/delegate_activation_storage.ml index e7aead3a45159..7eb6b195d0af3 100644 --- a/src/proto_alpha/lib_protocol/delegate_activation_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_activation_storage.ml @@ -50,6 +50,7 @@ let set_inactive ctxt delegate = Storage.Contract.Inactive_delegate.add ctxt (Contract_repr.Implicit delegate) let set_active ctxt delegate = + let open Lwt_result_syntax in is_inactive ctxt delegate >>=? fun inactive -> let current_cycle = (Raw_context.current_level ctxt).cycle in let preserved_cycles = Constants_storage.preserved_cycles ctxt in @@ -65,15 +66,17 @@ let set_active ctxt delegate = delegate_contract >>=? fun current_last_active_cycle -> let last_active_cycle = + let open Result_syntax in match current_last_active_cycle with | None -> Cycle_repr.add current_cycle (1 + (2 * preserved_cycles)) | Some current_last_active_cycle -> let delay = if inactive then 1 + (2 * preserved_cycles) else 1 + preserved_cycles in - let updated = Cycle_repr.add current_cycle delay in - Cycle_repr.max current_last_active_cycle updated + let* updated = Cycle_repr.add current_cycle delay in + return @@ Cycle_repr.max current_last_active_cycle updated in + let*? last_active_cycle = last_active_cycle in Storage.Contract.Delegate_last_cycle_before_deactivation.add ctxt delegate_contract diff --git a/src/proto_alpha/lib_protocol/delegate_consensus_key.ml b/src/proto_alpha/lib_protocol/delegate_consensus_key.ml index 5b0ded930a8b0..dcef825ba6ad8 100644 --- a/src/proto_alpha/lib_protocol/delegate_consensus_key.ml +++ b/src/proto_alpha/lib_protocol/delegate_consensus_key.ml @@ -122,12 +122,8 @@ let active_key ctxt delegate = return (pkh pk) let raw_pending_updates ctxt delegate = - let open Lwt_result_syntax in - let*! pendings = - Storage.Contract.Pending_consensus_keys.bindings - (ctxt, Contract_repr.Implicit delegate) - in - return pendings + Storage.Contract.Pending_consensus_keys.bindings + (ctxt, Contract_repr.Implicit delegate) let pending_updates ctxt delegate = let open Lwt_result_syntax in @@ -163,7 +159,7 @@ let active_pubkey_for_cycle ctxt delegate cycle = let register_update ctxt delegate pk = let open Lwt_result_syntax in - let update_cycle = + let*? update_cycle = let current_level = Raw_context.current_level ctxt in let preserved_cycles = Constants_storage.preserved_cycles ctxt in Cycle_repr.add current_level.cycle (preserved_cycles + 1) @@ -196,9 +192,8 @@ let activate ctxt ~new_cycle = Storage.Delegates.fold ctxt ~order:`Undefined - ~init:(ok ctxt) + ~init:ctxt ~f:(fun delegate ctxt -> - let*? ctxt = ctxt in let delegate = Contract_repr.Implicit delegate in let* update = Storage.Contract.Pending_consensus_keys.find (ctxt, delegate) new_cycle diff --git a/src/proto_alpha/lib_protocol/delegate_cycles.ml b/src/proto_alpha/lib_protocol/delegate_cycles.ml index 4335ceeecafb7..9e96c6e7d26d1 100644 --- a/src/proto_alpha/lib_protocol/delegate_cycles.ml +++ b/src/proto_alpha/lib_protocol/delegate_cycles.ml @@ -26,16 +26,17 @@ (*****************************************************************************) let update_activity ctxt last_cycle = + let open Lwt_result_syntax in let preserved = Constants_storage.preserved_cycles ctxt in - match Cycle_repr.sub last_cycle preserved with + let*? res = Cycle_repr.sub last_cycle preserved in + match res with | None -> return (ctxt, []) | Some _unfrozen_cycle -> Stake_storage.fold_on_active_delegates_with_minimal_stake ctxt ~order:`Sorted - ~init:(Ok (ctxt, [])) - ~f:(fun delegate () acc -> - acc >>?= fun (ctxt, deactivated) -> + ~init:(ctxt, []) + ~f:(fun delegate () (ctxt, deactivated) -> Delegate_activation_storage.last_cycle_before_deactivation ctxt delegate @@ -98,21 +99,23 @@ let max_frozen_deposits_and_delegates_to_remove ctxt ~from_cycle ~to_cycle = let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle ~balance_updates = + let open Lwt_result_syntax in let max_slashable_period = Constants_storage.max_slashing_period ctxt in (* We want to be able to slash for at most [max_slashable_period] *) - (match Cycle_repr.(sub new_cycle (max_slashable_period - 1)) with + let*? res = Cycle_repr.(sub new_cycle (max_slashable_period - 1)) in + (match res with | None -> Storage.Tenderbake.First_level_of_protocol.get ctxt >>=? fun first_level_of_protocol -> let cycle_eras = Raw_context.cycle_eras ctxt in - let level = + let*? level = Level_repr.level_from_raw ~cycle_eras first_level_of_protocol in return level.cycle | Some cycle -> return cycle) >>=? fun from_cycle -> let preserved_cycles = Constants_storage.preserved_cycles ctxt in - let to_cycle = Cycle_repr.(add new_cycle preserved_cycles) in + let*? to_cycle = Cycle_repr.(add new_cycle preserved_cycles) in max_frozen_deposits_and_delegates_to_remove ctxt ~from_cycle ~to_cycle >>=? fun (maxima, delegates_to_remove) -> Signature.Public_key_hash.Map.fold_es @@ -249,15 +252,17 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = delegates let cycle_end ctxt last_cycle = + let open Lwt_result_syntax in Seed_storage.cycle_end ctxt last_cycle >>=? fun (ctxt, unrevealed_nonces) -> - let new_cycle = Cycle_repr.add last_cycle 1 in + let*? new_cycle = Cycle_repr.add last_cycle 1 in Delegate_sampler.select_new_distribution_at_cycle_end ctxt ~new_cycle >>=? fun ctxt -> Delegate_consensus_key.activate ctxt ~new_cycle >>=? fun ctxt -> - Delegate_slashed_deposits_storage.clear_outdated_slashed_deposits - ctxt - ~new_cycle - >>= fun ctxt -> + let* ctxt = + Delegate_slashed_deposits_storage.clear_outdated_slashed_deposits + ctxt + ~new_cycle + in distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces >>=? fun (ctxt, balance_updates) -> freeze_deposits ctxt ~new_cycle ~balance_updates diff --git a/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml b/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml index c3e18d825341c..f29759dae8ce5 100644 --- a/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_missed_endorsements_storage.ml @@ -73,8 +73,8 @@ let record_endorsing_participation ctxt ~delegate ~participation block of the previous cycle, and when the delegate does not have an active stake at the current cycle; in this case its participation is simply ignored. *) - assert (Compare.Int32.(level.cycle_position = 0l)) ; - return ctxt + if Compare.Int32.(level.cycle_position = 0l) then return ctxt + else Lwt.return @@ error Internal_errors.Asserted | Some active_stake -> Stake_storage.get_total_active_stake ctxt level.cycle >>=? fun total_active_stake -> diff --git a/src/proto_alpha/lib_protocol/delegate_sampler.ml b/src/proto_alpha/lib_protocol/delegate_sampler.ml index e82285dfb5a56..fb5c2a6c48f0d 100644 --- a/src/proto_alpha/lib_protocol/delegate_sampler.ml +++ b/src/proto_alpha/lib_protocol/delegate_sampler.ml @@ -124,6 +124,7 @@ module Random = struct Raw_context.sampler_for_cycle ~read ctxt cycle let owner c (level : Level_repr.t) offset = + let open Lwt_result_syntax in let cycle = level.Level_repr.cycle in sampler_for_cycle c cycle >>=? fun (c, seed, state) -> let sample ~int_bound ~mass_bound = @@ -132,7 +133,7 @@ module Random = struct let elt, _ = take_int64 mass_bound state in (Int64.to_int i, elt) in - let pk = Sampler.sample state sample in + let*? pk = Sampler.sample state sample in return (c, pk) end @@ -226,13 +227,16 @@ let select_distribution_for_cycle ctxt cycle = Lwt.return (Raw_context.init_sampler_for_cycle ctxt cycle seed state) let select_new_distribution_at_cycle_end ctxt ~new_cycle = + let open Lwt_result_syntax in let preserved = Constants_storage.preserved_cycles ctxt in - let for_cycle = Cycle_repr.add new_cycle preserved in + let*? for_cycle = Cycle_repr.add new_cycle preserved in select_distribution_for_cycle ctxt for_cycle let clear_outdated_sampling_data ctxt ~new_cycle = + let open Lwt_result_syntax in let max_slashing_period = Constants_storage.max_slashing_period ctxt in - match Cycle_repr.sub new_cycle max_slashing_period with + let*? res = Cycle_repr.sub new_cycle max_slashing_period in + match res with | None -> return ctxt | Some outdated_cycle -> Delegate_sampler_state.remove_existing ctxt outdated_cycle diff --git a/src/proto_alpha/lib_protocol/delegate_services.ml b/src/proto_alpha/lib_protocol/delegate_services.ml index db989a7a0ba5e..c670fe34ccb36 100644 --- a/src/proto_alpha/lib_protocol/delegate_services.ml +++ b/src/proto_alpha/lib_protocol/delegate_services.ml @@ -398,7 +398,7 @@ let check_delegate_registered ctxt pkh = let register () = let open Services_registration in register0 ~chunked:true S.list_delegate (fun ctxt q () -> - Delegate.list ctxt >>= fun delegates -> + Delegate.list ctxt >>=? fun delegates -> (match q with | {active = true; inactive = false; _} -> List.filter_es @@ -434,7 +434,7 @@ let register () = Delegate.frozen_deposits ctxt pkh >>=? fun frozen_deposits -> Delegate.staking_balance ctxt pkh >>=? fun staking_balance -> Delegate.frozen_deposits_limit ctxt pkh >>=? fun frozen_deposits_limit -> - Delegate.delegated_contracts ctxt pkh >>= fun delegated_contracts -> + Delegate.delegated_contracts ctxt pkh >>=? fun delegated_contracts -> Delegate.delegated_balance ctxt pkh >>=? fun delegated_balance -> Delegate.deactivated ctxt pkh >>=? fun deactivated -> Delegate.last_cycle_before_deactivation ctxt pkh >>=? fun grace_period -> @@ -474,7 +474,7 @@ let register () = Delegate.frozen_deposits_limit ctxt pkh) ; register1 ~chunked:true S.delegated_contracts (fun ctxt pkh () () -> check_delegate_registered ctxt pkh >>=? fun () -> - Delegate.delegated_contracts ctxt pkh >|= ok) ; + Delegate.delegated_contracts ctxt pkh) ; register1 ~chunked:false S.delegated_balance (fun ctxt pkh () () -> check_delegate_registered ctxt pkh >>=? fun () -> Delegate.delegated_balance ctxt pkh) ; diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml index 8488eb8ba9696..28e84b19b1307 100644 --- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml @@ -42,12 +42,15 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) = let* slashed = Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate) in - let updated_slashed = + let*? updated_slashed = + let open Result_syntax in match slashed with - | None -> {Storage.for_double_endorsing = true; for_double_baking = false} + | None -> + return {Storage.for_double_endorsing = true; for_double_baking = false} | Some slashed -> - assert (Compare.Bool.(slashed.for_double_endorsing = false)) ; - {slashed with for_double_endorsing = true} + if Compare.Bool.(slashed.for_double_endorsing = false) then + return {slashed with for_double_endorsing = true} + else error Internal_errors.Asserted in let delegate_contract = Contract_repr.Implicit delegate in let* frozen_deposits = Frozen_deposits_storage.get ctxt delegate_contract in @@ -85,12 +88,15 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) = let* slashed = Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate) in - let updated_slashed = + let*? updated_slashed = + let open Result_syntax in match slashed with - | None -> {Storage.for_double_baking = true; for_double_endorsing = false} + | None -> + return {Storage.for_double_baking = true; for_double_endorsing = false} | Some slashed -> - assert (Compare.Bool.(slashed.for_double_baking = false)) ; - {slashed with for_double_baking = true} + if Compare.Bool.(slashed.for_double_baking = false) then + return {slashed with for_double_baking = true} + else error Internal_errors.Asserted in let delegate_contract = Contract_repr.Implicit delegate in let* frozen_deposits = Frozen_deposits_storage.get ctxt delegate_contract in @@ -117,7 +123,9 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) = return (ctxt, amount_to_burn, balance_updates) let clear_outdated_slashed_deposits ctxt ~new_cycle = + let open Lwt_result_syntax in let max_slashable_period = Constants_storage.max_slashing_period ctxt in - match Cycle_repr.(sub new_cycle max_slashable_period) with - | None -> Lwt.return ctxt + let*? res = Cycle_repr.(sub new_cycle max_slashable_period) in + match res with + | None -> return ctxt | Some outdated_cycle -> Storage.Slashed_deposits.clear (ctxt, outdated_cycle) diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli index 9dfb7c314b928..2e21789968717 100644 --- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli +++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli @@ -74,4 +74,4 @@ val punish_double_baking : (Raw_context.t * Tez_repr.t * Receipt_repr.balance_updates) tzresult Lwt.t val clear_outdated_slashed_deposits : - Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t Lwt.t + Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/delegate_storage.mli b/src/proto_alpha/lib_protocol/delegate_storage.mli index 9d809e2666057..83002e4a75216 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.mli +++ b/src/proto_alpha/lib_protocol/delegate_storage.mli @@ -95,11 +95,11 @@ val fold : Raw_context.t -> order:[`Sorted | `Undefined] -> init:'a -> - f:(Signature.Public_key_hash.t -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(Signature.Public_key_hash.t -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t (** List all registered delegates. *) -val list : Raw_context.t -> Signature.Public_key_hash.t list Lwt.t +val list : Raw_context.t -> Signature.Public_key_hash.t list tzresult Lwt.t val frozen_deposits_limit : Raw_context.t -> diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 4068f716b5992..66be0125fbc47 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -32,6 +32,7 @@ -open Tezos_protocol_environment_alpha.Pervasives -open Tezos_protocol_environment_alpha.Error_monad) (modules + Internal_errors Misc Non_empty_string Path_encoding @@ -305,6 +306,7 @@ (rule (alias runtest_compile_protocol) (deps + internal_erros.ml misc.ml misc.mli non_empty_string.ml non_empty_string.mli path_encoding.ml path_encoding.mli diff --git a/src/proto_alpha/lib_protocol/gas_input_size.ml b/src/proto_alpha/lib_protocol/gas_input_size.ml index c9bebe6f65d06..b3640fc357bc1 100644 --- a/src/proto_alpha/lib_protocol/gas_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_input_size.ml @@ -27,13 +27,15 @@ include Gas_comparable_input_size let list (list : 'a Script_list.t) : t = list.Script_list.length -let set (set : 'a Script_typed_ir.set) : t = +let set (set : 'a Script_typed_ir.set) : t tzresult = + let open Result_syntax in let res = Script_int.to_int (Script_set.size set) in - match res with None -> assert false | Some x -> x + match res with None -> error Internal_errors.Asserted | Some x -> return x -let map (map : ('a, 'b) Script_typed_ir.map) : t = +let map (map : ('a, 'b) Script_typed_ir.map) : t tzresult = + let open Result_syntax in let res = Script_int.to_int (Script_map.size map) in - match res with None -> assert false | Some x -> x + match res with None -> error Internal_errors.Asserted | Some x -> return x (* ------------------------------------------------------------------------- *) (* Micheline/Michelson-related *) diff --git a/src/proto_alpha/lib_protocol/gas_input_size.mli b/src/proto_alpha/lib_protocol/gas_input_size.mli index 6d3ba74fa43f8..a294a0e608266 100644 --- a/src/proto_alpha/lib_protocol/gas_input_size.mli +++ b/src/proto_alpha/lib_protocol/gas_input_size.mli @@ -36,9 +36,9 @@ include module type of Gas_comparable_input_size val list : 'a Script_list.t -> t -val set : 'a Script_typed_ir.set -> t +val set : 'a Script_typed_ir.set -> t tzresult -val map : ('a, 'b) Script_typed_ir.map -> t +val map : ('a, 'b) Script_typed_ir.map -> t tzresult (* ------------------------------------------------------------------------- *) (* Micheline/Michelson-related *) diff --git a/src/proto_alpha/lib_protocol/internal_errors.ml b/src/proto_alpha/lib_protocol/internal_errors.ml new file mode 100644 index 0000000000000..652f3f83522d1 --- /dev/null +++ b/src/proto_alpha/lib_protocol/internal_errors.ml @@ -0,0 +1,8 @@ +type error += Asserted + +let do_assert (b : bool) : unit tzresult = + let open Result_syntax in + if b then return_unit else error Asserted + +let ignore_errors (x : 'a tzresult) : 'a = + match x with Pervasives.Ok x -> x | Pervasives.Error _ -> assert false diff --git a/src/proto_alpha/lib_protocol/lazy_storage_kind.ml b/src/proto_alpha/lib_protocol/lazy_storage_kind.ml index 7e0ef5cba642a..ff0f779d6ce80 100644 --- a/src/proto_alpha/lib_protocol/lazy_storage_kind.ml +++ b/src/proto_alpha/lib_protocol/lazy_storage_kind.ml @@ -117,13 +117,13 @@ module MakeId (Title : Title) : TitleWithId = struct let is_temp z = Compare.Z.(z < Z.zero) - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path z l = Z.to_string z :: l - let of_path = function - | [] | _ :: _ :: _ -> None - | [z] -> Some (Z.of_string z) + let of_path : _ -> _ tzresult = function + | [] | _ :: _ :: _ -> ok None + | [z] -> ok @@ Some (Z.of_string z) end module Temp_id = struct diff --git a/src/proto_alpha/lib_protocol/level_repr.ml b/src/proto_alpha/lib_protocol/level_repr.ml index 805295c92326b..165f5bf67ba77 100644 --- a/src/proto_alpha/lib_protocol/level_repr.ml +++ b/src/proto_alpha/lib_protocol/level_repr.ml @@ -188,74 +188,89 @@ let cycle_eras_encoding = | Error _ -> Error "Invalid cycle eras") (Data_encoding.list cycle_era_encoding) -let current_era = function [] -> assert false | cycle_era :: _ -> cycle_era +let current_era eras = + let open Result_syntax in + match eras with + | [] -> error Internal_errors.Asserted + | cycle_era :: _ -> return cycle_era let root_level cycle_eras = + let open Result_syntax in let first_era = List.last_opt cycle_eras in - let first_era = + let* first_era = match first_era with - | Some first_era -> first_era + | Some first_era -> return first_era | None -> (* {!create_cycle_eras} fails if the list is empty. {!cycle_eras_encoding} uses {!create_cycle_eras} and so fails on empty lists too. *) - assert false + error Internal_errors.Asserted in - { - level = first_era.first_level; - level_position = 0l; - cycle = Cycle_repr.root; - cycle_position = 0l; - expected_commitment = false; - } + return + { + level = first_era.first_level; + level_position = 0l; + cycle = Cycle_repr.root; + cycle_position = 0l; + expected_commitment = false; + } (* This function returns the cycle era to which [level] belongs. *) let era_of_level ~cycle_eras level = + let open Result_syntax in let rec aux = function | ({first_level; _} as era) :: previous_eras -> - if Raw_level_repr.(level >= first_level) then era else aux previous_eras - | [] -> assert false + if Raw_level_repr.(level >= first_level) then return era + else aux previous_eras + | [] -> error Internal_errors.Asserted in aux cycle_eras (* This function returns the cycle era to which [cycle] belongs. *) let era_of_cycle ~cycle_eras cycle = + let open Result_syntax in let rec aux = function | ({first_cycle; _} as era) :: previous_eras -> - if Cycle_repr.(cycle >= first_cycle) then era else aux previous_eras - | [] -> assert false + if Cycle_repr.(cycle >= first_cycle) then return era + else aux previous_eras + | [] -> error Internal_errors.Asserted in aux cycle_eras (* precondition: [level] belongs to [era] *) let level_from_raw_with_era era ~first_level_in_alpha_family level = + let open Result_syntax in let {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment} = era in let level_position_in_era = Raw_level_repr.diff level first_level in - assert (Compare.Int32.(level_position_in_era >= 0l)) ; - let cycles_since_era_start = - Int32.div level_position_in_era blocks_per_cycle - in - let cycle = - Cycle_repr.add first_cycle (Int32.to_int cycles_since_era_start) - in - let cycle_position = Int32.rem level_position_in_era blocks_per_cycle in - let level_position = Raw_level_repr.diff level first_level_in_alpha_family in - let expected_commitment = - Compare.Int32.( - Int32.rem cycle_position blocks_per_commitment - = Int32.pred blocks_per_commitment) - in - {level; level_position; cycle; cycle_position; expected_commitment} + if Compare.Int32.(level_position_in_era >= 0l) then + let cycles_since_era_start = + Int32.div level_position_in_era blocks_per_cycle + in + let* cycle = + Cycle_repr.add first_cycle (Int32.to_int cycles_since_era_start) + in + let cycle_position = Int32.rem level_position_in_era blocks_per_cycle in + let level_position = + Raw_level_repr.diff level first_level_in_alpha_family + in + let expected_commitment = + Compare.Int32.( + Int32.rem cycle_position blocks_per_commitment + = Int32.pred blocks_per_commitment) + in + return {level; level_position; cycle; cycle_position; expected_commitment} + else error Internal_errors.Asserted let level_from_raw_aux_exn ~cycle_eras level = - let first_level_in_alpha_family = + let open Result_syntax in + let* first_level_in_alpha_family = match List.rev cycle_eras with - | [] -> assert false - | {first_level; _} :: _ -> first_level + | [] -> error Internal_errors.Asserted + | {first_level; _} :: _ -> return first_level in - let era = era_of_level ~cycle_eras level in + let* era = era_of_level ~cycle_eras level in level_from_raw_with_era era ~first_level_in_alpha_family level let level_from_raw ~cycle_eras l = level_from_raw_aux_exn ~cycle_eras l @@ -279,16 +294,18 @@ let () = (fun level -> Level_not_in_alpha level) let level_from_raw_aux ~cycle_eras level = - let first_level_in_alpha_family = + let open Result_syntax in + let* first_level_in_alpha_family = match List.rev cycle_eras with - | [] -> assert false - | {first_level; _} :: _ -> first_level + | [] -> error Internal_errors.Asserted + | {first_level; _} :: _ -> return first_level in - error_when - Raw_level_repr.(level < first_level_in_alpha_family) - (Level_not_in_alpha level) - >|? fun () -> - let era = era_of_level ~cycle_eras level in + let* () = + error_when + Raw_level_repr.(level < first_level_in_alpha_family) + (Level_not_in_alpha level) + in + let* era = era_of_level ~cycle_eras level in level_from_raw_with_era era ~first_level_in_alpha_family level type error += Negative_level_and_offset_sum of int32 * int32 @@ -312,21 +329,26 @@ let () = (fun (level, offset) -> Negative_level_and_offset_sum (level, offset)) let level_from_raw_with_offset ~cycle_eras ~offset raw_level = + let open Result_syntax in let res = Raw_level_repr.(of_int32 (Int32.add (to_int32 raw_level) offset)) in - match res with - | Ok level -> level_from_raw_aux ~cycle_eras level - | Error _ -> - error - (Negative_level_and_offset_sum - (Raw_level_repr.to_int32 raw_level, offset)) + let* level = + match res with + | Ok level -> Ok level + | Error _ -> + error + (Negative_level_and_offset_sum + (Raw_level_repr.to_int32 raw_level, offset)) + in + level_from_raw_aux ~cycle_eras level let first_level_in_cycle_from_eras ~cycle_eras cycle = - let first_level_in_alpha_family = + let open Result_syntax in + let* first_level_in_alpha_family = match List.rev cycle_eras with - | [] -> assert false - | {first_level; _} :: _ -> first_level + | [] -> error Internal_errors.Asserted + | {first_level; _} :: _ -> return first_level in - let era = era_of_cycle ~cycle_eras cycle in + let* era = era_of_cycle ~cycle_eras cycle in let cycle_position = Cycle_repr.diff cycle era.first_cycle in let offset = Int32.mul era.blocks_per_cycle cycle_position in let first_level_in_cycle = @@ -335,21 +357,27 @@ let first_level_in_cycle_from_eras ~cycle_eras cycle = level_from_raw_with_era era ~first_level_in_alpha_family first_level_in_cycle let last_of_cycle ~cycle_eras level = - let era = era_of_level ~cycle_eras level.level in - Compare.Int32.(Int32.succ level.cycle_position = era.blocks_per_cycle) + let open Result_syntax in + let* era = era_of_level ~cycle_eras level.level in + return Compare.Int32.(Int32.succ level.cycle_position = era.blocks_per_cycle) module Internal_for_tests = struct let add_level level n = + let open Result_syntax in let raw_level = level.level in - let new_raw_level = Raw_level_repr.add raw_level n in - {level with level = new_raw_level} + let* new_raw_level = Raw_level_repr.add raw_level n in + return {level with level = new_raw_level} let add_cycles ~blocks_per_cycle level n = - { - level with - cycle = Cycle_repr.add level.cycle n; - level = Raw_level_repr.add level.level (n * blocks_per_cycle); - level_position = - Int32.add level.level_position (Int32.of_int (n * blocks_per_cycle)); - } + let open Result_syntax in + let* cycle = Cycle_repr.add level.cycle n in + let* lvl = Raw_level_repr.add level.level (n * blocks_per_cycle) in + return + { + level with + cycle; + level = lvl; + level_position = + Int32.add level.level_position (Int32.of_int (n * blocks_per_cycle)); + } end diff --git a/src/proto_alpha/lib_protocol/level_repr.mli b/src/proto_alpha/lib_protocol/level_repr.mli index 0c2800556dc29..0ad03160a1835 100644 --- a/src/proto_alpha/lib_protocol/level_repr.mli +++ b/src/proto_alpha/lib_protocol/level_repr.mli @@ -89,13 +89,13 @@ val create_cycle_eras : cycle_era list -> cycle_eras tzresult val add_cycle_era : cycle_era -> cycle_eras -> cycle_eras tzresult (** Returns the current era *) -val current_era : cycle_eras -> cycle_era +val current_era : cycle_eras -> cycle_era tzresult (** Returns the first level of the oldest era *) -val root_level : cycle_eras -> level +val root_level : cycle_eras -> level tzresult (** Returns the annotated level corresponding to a raw level *) -val level_from_raw : cycle_eras:cycle_eras -> Raw_level_repr.t -> level +val level_from_raw : cycle_eras:cycle_eras -> Raw_level_repr.t -> level tzresult (** Returns the annotated level corresponding to a raw level and an offset. A positive offset corresponds to a higher level. @@ -107,15 +107,15 @@ val level_from_raw_with_offset : (** Returns the first level of the given cycle. *) val first_level_in_cycle_from_eras : - cycle_eras:cycle_eras -> Cycle_repr.t -> level + cycle_eras:cycle_eras -> Cycle_repr.t -> level tzresult (** Returns true if the given level is the last of a cycle. *) -val last_of_cycle : cycle_eras:cycle_eras -> level -> bool +val last_of_cycle : cycle_eras:cycle_eras -> level -> bool tzresult module Internal_for_tests : sig - val add_level : t -> int -> t + val add_level : t -> int -> t tzresult - val add_cycles : blocks_per_cycle:int -> t -> int -> t + val add_cycles : blocks_per_cycle:int -> t -> int -> t tzresult end (**/**) diff --git a/src/proto_alpha/lib_protocol/level_storage.ml b/src/proto_alpha/lib_protocol/level_storage.ml index 057588f457f39..dfdbcdc31f924 100644 --- a/src/proto_alpha/lib_protocol/level_storage.ml +++ b/src/proto_alpha/lib_protocol/level_storage.ml @@ -38,79 +38,102 @@ let root c = Raw_context.cycle_eras c |> Level_repr.root_level let succ c (l : Level_repr.t) = from_raw c (Raw_level_repr.succ l.level) let pred c (l : Level_repr.t) = + let open Result_syntax in match Raw_level_repr.pred l.Level_repr.level with - | None -> None - | Some l -> Some (from_raw c l) + | None -> return_none + | Some l -> + let* x = from_raw c l in + return_some x -let add c (l : Level_repr.t) n = from_raw c (Raw_level_repr.add l.level n) +let add c (l : Level_repr.t) n = + let open Result_syntax in + let* res = Raw_level_repr.add l.level n in + from_raw c res let sub c (l : Level_repr.t) n = - match Raw_level_repr.sub l.level n with - | None -> None + let open Result_syntax in + let* res = Raw_level_repr.sub l.level n in + match res with + | None -> return None | Some raw_level -> let cycle_eras = Raw_context.cycle_eras c in - let root_level = Level_repr.root_level cycle_eras in + let* root_level = Level_repr.root_level cycle_eras in if Raw_level_repr.(raw_level >= root_level.level) then - Some (from_raw c raw_level) - else None + let* fr = from_raw c raw_level in + return_some fr + else return_none let current ctxt = Raw_context.current_level ctxt let previous ctxt = + let open Result_syntax in let l = current ctxt in - match pred ctxt l with - | None -> assert false (* We never validate the Genesis... *) - | Some p -> p + let* p = pred ctxt l in + match p with + | None -> + tzfail Internal_errors.Asserted (* We never validate the Genesis... *) + | Some p -> return p let first_level_in_cycle ctxt cycle = let cycle_eras = Raw_context.cycle_eras ctxt in Level_repr.first_level_in_cycle_from_eras ~cycle_eras cycle let last_level_in_cycle ctxt c = - match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with - | None -> assert false - | Some x -> x + let open Result_syntax in + let* level = first_level_in_cycle ctxt (Cycle_repr.succ c) in + let* p = pred ctxt level in + match p with None -> tzfail Internal_errors.Asserted | Some x -> return x let levels_in_cycle ctxt cycle = - let first = first_level_in_cycle ctxt cycle in + let open Result_syntax in + let* first = first_level_in_cycle ctxt cycle in 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 + let* sn = succ ctxt n in + if Cycle_repr.(n.cycle = first.cycle) then loop sn (n :: acc) + else return acc in loop first [] let levels_in_current_cycle ctxt ?(offset = 0l) () = + let open Result_syntax in let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in let cycle = Int32.add current_cycle offset in - if Compare.Int32.(cycle < 0l) then [] + if Compare.Int32.(cycle < 0l) then return [] else let cycle = Cycle_repr.of_int32_exn cycle in levels_in_cycle ctxt cycle let levels_with_commitments_in_cycle ctxt c = - let first = first_level_in_cycle ctxt c in + let open Result_syntax in + let* first = first_level_in_cycle ctxt c in 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 - else acc + let* sn = succ ctxt n in + if n.expected_commitment then loop sn (n :: acc) else loop sn acc + else return acc in loop first [] let last_allowed_fork_level c = + let open Result_syntax in let level = Raw_context.current_level c in let preserved_cycles = Constants_storage.preserved_cycles c in - match Cycle_repr.sub level.cycle preserved_cycles with - | None -> Raw_level_repr.root - | Some cycle -> (first_level_in_cycle c cycle).level + let* res = Cycle_repr.sub level.cycle preserved_cycles in + match res with + | None -> return Raw_level_repr.root + | Some cycle -> + let* res = first_level_in_cycle c cycle in + return res.level let last_of_a_cycle ctxt level = let cycle_eras = Raw_context.cycle_eras ctxt in Level_repr.last_of_cycle ~cycle_eras level let dawn_of_a_new_cycle ctxt = + let open Result_syntax in let level = current ctxt in - if last_of_a_cycle ctxt level then Some level.cycle else None + let* loac = last_of_a_cycle ctxt level in + if loac then return @@ Some level.cycle else return None let may_snapshot_stake_distribution ctxt = let level = current ctxt in diff --git a/src/proto_alpha/lib_protocol/level_storage.mli b/src/proto_alpha/lib_protocol/level_storage.mli index 0049a81854518..b19136d26c16b 100644 --- a/src/proto_alpha/lib_protocol/level_storage.mli +++ b/src/proto_alpha/lib_protocol/level_storage.mli @@ -25,46 +25,48 @@ val current : Raw_context.t -> Level_repr.t -val previous : Raw_context.t -> Level_repr.t +val previous : Raw_context.t -> Level_repr.t tzresult -val root : Raw_context.t -> Level_repr.t +val root : Raw_context.t -> Level_repr.t tzresult -val from_raw : Raw_context.t -> Raw_level_repr.t -> Level_repr.t +val from_raw : Raw_context.t -> Raw_level_repr.t -> Level_repr.t tzresult (** Fails with [Negative_level_and_offset_sum] if the sum of the raw_level and the offset is negative. *) val from_raw_with_offset : Raw_context.t -> offset:int32 -> Raw_level_repr.t -> Level_repr.t tzresult -val pred : Raw_context.t -> Level_repr.t -> Level_repr.t option +val pred : Raw_context.t -> Level_repr.t -> Level_repr.t option tzresult -val succ : Raw_context.t -> Level_repr.t -> Level_repr.t +val succ : Raw_context.t -> Level_repr.t -> Level_repr.t tzresult (** [i] must be positive *) -val add : Raw_context.t -> Level_repr.t -> int -> Level_repr.t +val add : Raw_context.t -> Level_repr.t -> int -> Level_repr.t tzresult (** [sub c level i] returns None if the level is before the first level of the Alpha family of protocol, otherwise it returns the expected level. [i] must be positive. *) -val sub : Raw_context.t -> Level_repr.t -> int -> Level_repr.t option +val sub : Raw_context.t -> Level_repr.t -> int -> Level_repr.t option tzresult -val first_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t +val first_level_in_cycle : + Raw_context.t -> Cycle_repr.t -> Level_repr.t tzresult -val last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t +val last_level_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t tzresult -val levels_in_cycle : Raw_context.t -> Cycle_repr.t -> Level_repr.t list +val levels_in_cycle : + Raw_context.t -> Cycle_repr.t -> Level_repr.t list tzresult val levels_in_current_cycle : - Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list + Raw_context.t -> ?offset:int32 -> unit -> Level_repr.t list tzresult val levels_with_commitments_in_cycle : - Raw_context.t -> Cycle_repr.t -> Level_repr.t list + Raw_context.t -> Cycle_repr.t -> Level_repr.t list tzresult -val last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t +val last_allowed_fork_level : Raw_context.t -> Raw_level_repr.t tzresult (** Returns [Some cycle] if the current level represents the last level of [cycle] and [None] if the level is not the last level of a cycle. *) -val dawn_of_a_new_cycle : Raw_context.t -> Cycle_repr.t option +val dawn_of_a_new_cycle : Raw_context.t -> Cycle_repr.t option tzresult (** Returns [true] if the stake distribution should be snapshot at the current level. *) diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index db0c084f7c1ca..161e2af4c6519 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -152,7 +152,7 @@ let prepare_ctxt ctxt mode ~(predecessor : Block_header.shell_header) = prepare ctxt ~level ~predecessor_timestamp:predecessor.timestamp ~timestamp in let*? predecessor_raw_level = Raw_level.of_int32 predecessor.level in - let predecessor_level = Level.from_raw ctxt predecessor_raw_level in + let*? predecessor_level = Level.from_raw ctxt predecessor_raw_level in (* During block (full or partial) application or full construction, endorsements must be for [predecessor_level] and preendorsements, if any, for the block's level. In the mempool (partial @@ -383,8 +383,11 @@ let init chain_id ctxt block_header = : Alpha_context.Block_header.contents) in Alpha_context.Cache.Admin.sync ctxt cache_nonce >>= fun ctxt -> - return - (Alpha_context.finalize ctxt (Alpha_context.Fitness.to_raw init_fitness)) + let open Lwt_result_syntax in + let*? res = + Alpha_context.finalize ctxt (Alpha_context.Fitness.to_raw init_fitness) + in + return res let value_of_key ~chain_id:_ ~predecessor_context:ctxt ~predecessor_timestamp ~predecessor_level:pred_level ~predecessor_fitness:_ ~predecessor:_ diff --git a/src/proto_alpha/lib_protocol/path_encoding.ml b/src/proto_alpha/lib_protocol/path_encoding.ml index 935986395bfda..3f38c091da6a0 100644 --- a/src/proto_alpha/lib_protocol/path_encoding.ml +++ b/src/proto_alpha/lib_protocol/path_encoding.ml @@ -29,9 +29,9 @@ module type S = sig val to_path : t -> string list -> string list - val of_path : string list -> t option + val of_path : string list -> t option tzresult - val path_length : int + val path_length : int tzresult end module type ENCODING = sig @@ -43,13 +43,13 @@ module type ENCODING = sig end module Make_hex (H : ENCODING) = struct - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path t l = let (`Hex key) = Hex.of_bytes (H.to_bytes t) in key :: l - let of_path = function - | [path] -> Option.bind (Hex.to_bytes (`Hex path)) H.of_bytes_opt - | _ -> None + let of_path : _ -> _ tzresult = function + | [path] -> ok @@ Option.bind (Hex.to_bytes (`Hex path)) H.of_bytes_opt + | _ -> ok None end diff --git a/src/proto_alpha/lib_protocol/path_encoding.mli b/src/proto_alpha/lib_protocol/path_encoding.mli index e44d1db35038d..48679b7b60f13 100644 --- a/src/proto_alpha/lib_protocol/path_encoding.mli +++ b/src/proto_alpha/lib_protocol/path_encoding.mli @@ -32,10 +32,10 @@ module type S = sig val to_path : t -> string list -> string list (** [of_path path] parses [path] as a context path name for [t] *) - val of_path : string list -> t option + val of_path : string list -> t option tzresult (** Directory levels of the path encoding of [t] *) - val path_length : int + val path_length : int tzresult end module type ENCODING = sig diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 0038b699b71c0..9477c2b67db4e 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -198,13 +198,14 @@ module Raw_consensus = struct } let set_preendorsements_quorum_round round t = + let open Result_syntax in match t.preendorsements_quorum_round with | Some round' -> (* If the rounds are different, an error should have already been raised. *) - assert (Round_repr.equal round round') ; - t - | None -> {t with preendorsements_quorum_round = Some round} + if Round_repr.equal round round' then return t + else error Internal_errors.Asserted + | None -> return {t with preendorsements_quorum_round = Some round} let initialize_with_endorsements_and_preendorsements ~allowed_endorsements ~allowed_preendorsements t = @@ -782,14 +783,18 @@ let check_inited ctxt = let check_cycle_eras (cycle_eras : Level_repr.cycle_eras) (constants : Constants_parametric_repr.t) = - let current_era = Level_repr.current_era cycle_eras in - assert ( - Compare.Int32.(current_era.blocks_per_cycle = constants.blocks_per_cycle)) ; - assert ( - Compare.Int32.( - current_era.blocks_per_commitment = constants.blocks_per_commitment)) - -let prepare ~level ~predecessor_timestamp ~timestamp ctxt = + let open Result_syntax in + let* current_era = Level_repr.current_era cycle_eras in + if Compare.Int32.(current_era.blocks_per_cycle = constants.blocks_per_cycle) + then + if + Compare.Int32.( + current_era.blocks_per_commitment = constants.blocks_per_commitment) + then return_unit + else tzfail Internal_errors.Asserted + else tzfail Internal_errors.Asserted + +let prepare ~level ~predecessor_timestamp ~timestamp ctxt : t tzresult Lwt.t = Raw_level_repr.of_int32 level >>?= fun level -> check_inited ctxt >>=? fun () -> get_constants ctxt >>=? fun constants -> @@ -797,45 +802,46 @@ let prepare ~level ~predecessor_timestamp ~timestamp ctxt = ~first_round_duration:constants.minimal_block_delay ~delay_increment_per_round:constants.delay_increment_per_round >>?= fun round_durations -> - get_cycle_eras ctxt >|=? fun cycle_eras -> - check_cycle_eras cycle_eras constants ; - let level = Level_repr.level_from_raw ~cycle_eras level in - { - remaining_operation_gas = Gas_limit_repr.Arith.zero; - back = - { - context = ctxt; - constants; - level; - predecessor_timestamp; - timestamp; - round_durations; - cycle_eras; - fees = Tez_repr.zero; - origination_nonce = None; - temporary_lazy_storage_ids = Lazy_storage_kind.Temp_ids.init; - internal_nonce = 0; - internal_nonces_used = Int_set.empty; - remaining_block_gas = - Gas_limit_repr.Arith.fp - constants.Constants_parametric_repr.hard_gas_limit_per_block; - unlimited_operation_gas = true; - consensus = Raw_consensus.empty; - non_consensus_operations_rev = []; - dictator_proposal_seen = false; - sampler_state = Cycle_repr.Map.empty; - stake_distribution_for_current_cycle = None; - tx_rollup_current_messages = Tx_rollup_repr.Map.empty; - sc_rollup_current_messages = None; - dal_slot_fee_market = - Dal_slot_repr.Slot_market.init - ~length:constants.Constants_parametric_repr.dal.number_of_slots; - dal_attestation_slot_accountability = - Dal_attestation_repr.Accountability.init - ~length:constants.Constants_parametric_repr.dal.number_of_slots; - dal_committee = empty_dal_committee; - }; - } + get_cycle_eras ctxt >>=? fun cycle_eras -> + check_cycle_eras cycle_eras constants >>?= fun () -> + Level_repr.level_from_raw ~cycle_eras level >>?= fun level -> + return + { + remaining_operation_gas = Gas_limit_repr.Arith.zero; + back = + { + context = ctxt; + constants; + level; + predecessor_timestamp; + timestamp; + round_durations; + cycle_eras; + fees = Tez_repr.zero; + origination_nonce = None; + temporary_lazy_storage_ids = Lazy_storage_kind.Temp_ids.init; + internal_nonce = 0; + internal_nonces_used = Int_set.empty; + remaining_block_gas = + Gas_limit_repr.Arith.fp + constants.Constants_parametric_repr.hard_gas_limit_per_block; + unlimited_operation_gas = true; + consensus = Raw_consensus.empty; + non_consensus_operations_rev = []; + dictator_proposal_seen = false; + sampler_state = Cycle_repr.Map.empty; + stake_distribution_for_current_cycle = None; + tx_rollup_current_messages = Tx_rollup_repr.Map.empty; + sc_rollup_current_messages = None; + dal_slot_fee_market = + Dal_slot_repr.Slot_market.init + ~length:constants.Constants_parametric_repr.dal.number_of_slots; + dal_attestation_slot_accountability = + Dal_attestation_repr.Accountability.init + ~length:constants.Constants_parametric_repr.dal.number_of_slots; + dal_committee = empty_dal_committee; + }; + } type previous_protocol = Genesis of Parameters_repr.t | Lima_015 @@ -1300,20 +1306,24 @@ let init_stake_distribution_for_current_cycle ctxt module Internal_for_tests = struct let add_level ctxt l = - let new_level = Level_repr.Internal_for_tests.add_level ctxt.back.level l in + let open Result_syntax in + let* new_level = + Level_repr.Internal_for_tests.add_level ctxt.back.level l + in let new_back = {ctxt.back with level = new_level} in - {ctxt with back = new_back} + return {ctxt with back = new_back} let add_cycles ctxt l = + let open Result_syntax in let blocks_per_cycle = Int32.to_int (constants ctxt).blocks_per_cycle in - let new_level = + let* new_level = Level_repr.Internal_for_tests.add_cycles ~blocks_per_cycle ctxt.back.level l in let new_back = {ctxt.back with level = new_level} in - {ctxt with back = new_back} + return {ctxt with back = new_back} end module type CONSENSUS = sig @@ -1353,7 +1363,7 @@ module type CONSENSUS = sig val get_preendorsements_quorum_round : t -> round option - val set_preendorsements_quorum_round : t -> round -> t + val set_preendorsements_quorum_round : t -> round -> t tzresult val locked_round_evidence : t -> (round * int) option @@ -1421,7 +1431,7 @@ module Consensus : let[@inline] endorsements_seen ctxt = ctxt.back.consensus.endorsements_seen let[@inline] set_preendorsements_quorum_round ctxt round = - update_consensus_with + update_consensus_with_tzresult ctxt (Raw_consensus.set_preendorsements_quorum_round round) diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index 30b59e479686c..3c6a70f231f00 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -282,9 +282,9 @@ val init_stake_distribution_for_current_cycle : t -> Tez_repr.t Signature.Public_key_hash.Map.t -> t module Internal_for_tests : sig - val add_level : t -> int -> t + val add_level : t -> int -> t tzresult - val add_cycles : t -> int -> t + val add_cycles : t -> int -> t tzresult end module type CONSENSUS = sig @@ -360,7 +360,7 @@ module type CONSENSUS = sig called only once. This function is only used in [Full_construction] mode. *) - val set_preendorsements_quorum_round : t -> round -> t + val set_preendorsements_quorum_round : t -> round -> t tzresult (** [locked_round_evidence ctx] returns the round of the recorded preendorsements as well as their power. *) diff --git a/src/proto_alpha/lib_protocol/raw_level_repr.ml b/src/proto_alpha/lib_protocol/raw_level_repr.ml index 24ac0327882eb..fe34892ea6b03 100644 --- a/src/proto_alpha/lib_protocol/raw_level_repr.ml +++ b/src/proto_alpha/lib_protocol/raw_level_repr.ml @@ -51,13 +51,16 @@ let root = 0l let succ = Int32.succ let add l i = - assert (Compare.Int.(i >= 0)) ; - Int32.add l (Int32.of_int i) + let open Result_syntax in + if Compare.Int.(i >= 0) then return @@ Int32.add l (Int32.of_int i) + else error Internal_errors.Asserted let sub l i = - assert (Compare.Int.(i >= 0)) ; - let res = Int32.sub l (Int32.of_int i) in - if Compare.Int32.(res >= 0l) then Some res else None + let open Result_syntax in + if Compare.Int.(i >= 0) then + let res = Int32.sub l (Int32.of_int i) in + if Compare.Int32.(res >= 0l) then return_some res else return_none + else error Internal_errors.Asserted let pred l = if l = 0l then None else Some (Int32.pred l) @@ -66,9 +69,12 @@ let diff = Int32.sub let to_int32 l = l let to_int32_non_negative l = + let open Result_syntax in match Bounded.Non_negative_int32.of_value l with - | Some x -> x - | _ -> assert false (* invariant: raw_levels are non-negative *) + | Some x -> return x + | _ -> + error + Internal_errors.Asserted (* invariant: raw_levels are non-negative *) type error += Unexpected_level of Int32.t (* `Permanent *) @@ -96,9 +102,12 @@ let of_int32_exn l = | Error _ -> invalid_arg "Level_repr.of_int32" let of_int32_non_negative l = + let open Result_syntax in match of_int32 (Bounded.Non_negative_int32.to_value l) with - | Ok l -> l - | Error _ -> assert false (* invariant: raw_levels are non-negative *) + | Ok l -> return l + | Error _ -> + error + Internal_errors.Asserted (* invariant: raw_levels are non-negative *) let encoding = Data_encoding.conv_with_guard @@ -112,11 +121,13 @@ let encoding = module Index = struct type t = raw_level - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path level l = Int32.to_string level :: l - let of_path = function [s] -> Int32.of_string_opt s | _ -> None + let of_path : _ -> _ tzresult = function + | [s] -> ok @@ Int32.of_string_opt s + | _ -> ok None let rpc_arg = rpc_arg diff --git a/src/proto_alpha/lib_protocol/raw_level_repr.mli b/src/proto_alpha/lib_protocol/raw_level_repr.mli index cdfcb175d57d4..4abbd6fc6e6fd 100644 --- a/src/proto_alpha/lib_protocol/raw_level_repr.mli +++ b/src/proto_alpha/lib_protocol/raw_level_repr.mli @@ -45,7 +45,7 @@ include Compare.S with type t := raw_level val to_int32 : raw_level -> int32 -val to_int32_non_negative : raw_level -> Bounded.Non_negative_int32.t +val to_int32_non_negative : raw_level -> Bounded.Non_negative_int32.t tzresult (** @raise Invalid_argument when the level to encode is negative *) val of_int32_exn : int32 -> raw_level @@ -53,7 +53,7 @@ val of_int32_exn : int32 -> raw_level (** Can trigger Unexpected_level error when the level to encode is negative *) val of_int32 : int32 -> raw_level tzresult -val of_int32_non_negative : Bounded.Non_negative_int32.t -> raw_level +val of_int32_non_negative : Bounded.Non_negative_int32.t -> raw_level tzresult val diff : raw_level -> raw_level -> int32 @@ -64,9 +64,9 @@ val succ : raw_level -> raw_level val pred : raw_level -> raw_level option (** [add l i] i must be positive *) -val add : raw_level -> int -> raw_level +val add : raw_level -> int -> raw_level tzresult (** [sub l i] i must be positive *) -val sub : raw_level -> int -> raw_level option +val sub : raw_level -> int -> raw_level option tzresult module Index : Storage_description.INDEX with type t = raw_level diff --git a/src/proto_alpha/lib_protocol/sampler.ml b/src/proto_alpha/lib_protocol/sampler.ml index 1aab07130e6e3..b44b28bbddc2d 100644 --- a/src/proto_alpha/lib_protocol/sampler.ml +++ b/src/proto_alpha/lib_protocol/sampler.ml @@ -28,7 +28,7 @@ This module implements the alias method for sampling from a given distribution. The distribution need not be normalized. -*) + *) module type SMass = sig type t @@ -59,7 +59,8 @@ module type S = sig val create : ('a * mass) list -> 'a t - val sample : 'a t -> (int_bound:int -> mass_bound:mass -> int * mass) -> 'a + val sample : + 'a t -> (int_bound:int -> mass_bound:mass -> int * mass) -> 'a tzresult val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t end @@ -129,14 +130,15 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct {total; support; p; alias} let sample {total; support; p; alias} draw_i_elt = + let open Result_syntax in let n = FallbackArray.length support in let i, elt = draw_i_elt ~int_bound:n ~mass_bound:total in let p = FallbackArray.get p i in - if Mass.(elt < p) then FallbackArray.get support i + if Mass.(elt < p) then return @@ FallbackArray.get support i else let j = FallbackArray.get alias i in - assert (Compare.Int.(j >= 0)) ; - FallbackArray.get support j + if Compare.Int.(j >= 0) then return @@ FallbackArray.get support j + else error Internal_errors.Asserted (* Note: this could go in the environment maybe? *) let array_encoding : 'a Data_encoding.t -> 'a FallbackArray.t Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/sampler.mli b/src/proto_alpha/lib_protocol/sampler.mli index 00cf20a7768c0..9f07b3ea3390b 100644 --- a/src/proto_alpha/lib_protocol/sampler.mli +++ b/src/proto_alpha/lib_protocol/sampler.mli @@ -57,7 +57,8 @@ module type S = sig bound is at most the length of the list passed to [create] when creating [auxdata]. The second bound is at most the sum of all items in the list passed to [create]. *) - val sample : 'a t -> (int_bound:int -> mass_bound:mass -> int * mass) -> 'a + val sample : + 'a t -> (int_bound:int -> mass_bound:mass -> int * mass) -> 'a tzresult (** [encoding e] constructs an encoding for ['a t] given an encoding for ['a]. *) val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml index 88a33e6239695..31439b2702916 100644 --- a/src/proto_alpha/lib_protocol/sapling_storage.ml +++ b/src/proto_alpha/lib_protocol/sapling_storage.ml @@ -102,29 +102,36 @@ module Commitments : COMMITMENTS = struct let max_size = pow2 max_height let assert_node node height = - assert ( - let first_of_height = pow2 (max_height - height) in - let first_of_next_height = Int64.shift_left first_of_height 1 in - Compare.Int64.(node >= first_of_height && node < first_of_next_height)) + let open Result_syntax in + let first_of_height = pow2 (max_height - height) in + let first_of_next_height = Int64.shift_left first_of_height 1 in + if Compare.Int64.(node >= first_of_height && node < first_of_next_height) + then return_unit + else error Internal_errors.Asserted let assert_height height = - assert (Compare.Int.(height >= 0 && height <= max_height)) + let open Result_syntax in + if Compare.Int.(height >= 0 && height <= max_height) then return_unit + else error Internal_errors.Asserted let assert_pos pos height = - assert (Compare.Int64.(pos >= 0L && pos <= pow2 height)) + let open Result_syntax in + if Compare.Int64.(pos >= 0L && pos <= pow2 height) then return_unit + else error Internal_errors.Asserted let default_root = H.uncommitted ~height:max_height let init = Storage.Sapling.commitments_init let get_root_height ctx id node height = - assert_node node height ; - assert_height height ; - Storage.Sapling.Commitments.find (ctx, id) node >|=? function + let open Lwt_result_syntax in + let*? _ = assert_node node height in + let*? _ = assert_height height in + Storage.Sapling.Commitments.find (ctx, id) node >>=? function | ctx, None -> let hash = H.uncommitted ~height in - (ctx, hash) - | ctx, Some hash -> (ctx, hash) + return (ctx, hash) + | ctx, Some hash -> return (ctx, hash) let left node = Int64.mul node 2L @@ -150,9 +157,10 @@ module Commitments : COMMITMENTS = struct Post: incremental tree /\ to_list (insert tree height pos cms) = to_list t @ cms *) let[@coq_struct "height"] rec insert ctx id node height pos cms = - assert_node node height ; - assert_height height ; - assert_pos pos height ; + let open Lwt_result_syntax in + let*? _ = assert_node node height in + let*? _ = assert_height height in + let*? _ = assert_pos pos height in match (height, cms) with | _, [] -> get_root_height ctx id node height >|=? fun (ctx, h) -> (ctx, 0, h) @@ -180,9 +188,10 @@ module Commitments : COMMITMENTS = struct let[@coq_struct "height"] rec fold_from_height ctx id node ~pos ~f ~acc height = - assert_node node height ; - assert_height height ; - assert_pos pos height ; + let open Lwt_result_syntax in + let*? _ = assert_node node height in + let*? _ = assert_height height in + let*? _ = assert_pos pos height in Storage.Sapling.Commitments.find (ctx, id) node (* we don't count gas for this function, it is called only by RPC *) >>=? @@ -214,11 +223,13 @@ module Commitments : COMMITMENTS = struct less relevant on a smaller list. *) let add ctx id cms pos = let l = List.length cms in - assert (Compare.Int.(l <= 1000)) ; - let n' = Int64.(add pos (of_int l)) in - assert (Compare.Int64.(n' <= max_size)) ; - insert ctx id root_node max_height pos cms >|=? fun (ctx, size, _h) -> - (ctx, size) + if Compare.Int.(l <= 1000) then + let n' = Int64.(add pos (of_int l)) in + if Compare.Int64.(n' <= max_size) then + insert ctx id root_node max_height pos cms >|=? fun (ctx, size, _h) -> + (ctx, size) + else Lwt.return @@ error Internal_errors.Asserted + else Lwt.return @@ error Internal_errors.Asserted let get_from ctx id pos = fold_from_height @@ -264,19 +275,20 @@ module Nullifiers = struct Not tail-recursive so we put a hard limit on the size of the list of nullifiers. *) let add ctx id nfs = - assert (Compare.Int.(List.compare_length_with nfs 1000 <= 0)) ; - size ctx id >>=? fun nf_start_pos -> - List.fold_right_es - (fun nf (ctx, pos, acc_size) -> - Storage.Sapling.Nullifiers_hashed.init (ctx, id) nf - >>=? fun (ctx, size) -> - Storage.Sapling.Nullifiers_ordered.init (ctx, id) pos nf >|=? fun ctx -> - (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size))) - nfs - (ctx, nf_start_pos, Z.zero) - >>=? fun (ctx, nf_end_pos, size) -> - Storage.Sapling.Nullifiers_size.update (ctx, id) nf_end_pos >|=? fun ctx -> - (ctx, size) + if Compare.Int.(List.compare_length_with nfs 1000 <= 0) then + size ctx id >>=? fun nf_start_pos -> + List.fold_right_es + (fun nf (ctx, pos, acc_size) -> + Storage.Sapling.Nullifiers_hashed.init (ctx, id) nf + >>=? fun (ctx, size) -> + Storage.Sapling.Nullifiers_ordered.init (ctx, id) pos nf + >|=? fun ctx -> (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size))) + nfs + (ctx, nf_start_pos, Z.zero) + >>=? fun (ctx, nf_end_pos, size) -> + Storage.Sapling.Nullifiers_size.update (ctx, id) nf_end_pos + >|=? fun ctx -> (ctx, size) + else Lwt.return @@ error Internal_errors.Asserted let get_from ctx id offset = let[@coq_struct "pos"] rec aux acc pos = diff --git a/src/proto_alpha/lib_protocol/sapling_validator.ml b/src/proto_alpha/lib_protocol/sapling_validator.ml index a9784cae94210..b9c1975705068 100644 --- a/src/proto_alpha/lib_protocol/sapling_validator.ml +++ b/src/proto_alpha/lib_protocol/sapling_validator.ml @@ -45,64 +45,69 @@ let verify_update : string -> (Raw_context.t * (Int64.t * Sapling_storage.state) option) tzresult Lwt.t = fun ctxt state transaction key -> + let open Lwt_result_syntax in (* Check the transaction *) (* To avoid overflowing the balance, the number of inputs and outputs must be bounded. Ciphertexts' memo_size must match the state's memo_size. These constraints are already enforced at the encoding level. *) - assert (Compare.Int.(List.compare_length_with transaction.inputs 5208 <= 0)) ; - assert (Compare.Int.(List.compare_length_with transaction.outputs 2019 <= 0)) ; - let pass = - List.for_all - (fun output -> - Compare.Int.( - Sapling.Ciphertext.get_memo_size Sapling.UTXO.(output.ciphertext) - = state.memo_size)) - transaction.outputs - in - if not pass then return (ctxt, None) - else - (* Check the root is a recent state *) - Sapling_storage.root_mem ctxt state transaction.root >>=? fun pass -> + if + Compare.Int.(List.compare_length_with transaction.inputs 5208 <= 0) + && Compare.Int.(List.compare_length_with transaction.outputs 2019 <= 0) + then + let pass = + List.for_all + (fun output -> + Compare.Int.( + Sapling.Ciphertext.get_memo_size Sapling.UTXO.(output.ciphertext) + = state.memo_size)) + transaction.outputs + in if not pass then return (ctxt, None) else - check_and_update_nullifiers ctxt state transaction.inputs >|=? function - | ctxt, None -> (ctxt, None) - | ctxt, Some state -> - Sapling.Verification.with_verification_ctx (fun vctx -> - let pass = - (* Check all the output ZK proofs *) - List.for_all - (fun output -> Sapling.Verification.check_output vctx output) - transaction.outputs - in - if not pass then (ctxt, None) - else + (* Check the root is a recent state *) + Sapling_storage.root_mem ctxt state transaction.root >>=? fun pass -> + if not pass then return (ctxt, None) + else + check_and_update_nullifiers ctxt state transaction.inputs >|=? function + | ctxt, None -> (ctxt, None) + | ctxt, Some state -> + Sapling.Verification.with_verification_ctx (fun vctx -> let pass = - (* Check all the input Zk proofs and signatures *) + (* Check all the output ZK proofs *) List.for_all - (fun input -> - Sapling.Verification.check_spend - vctx - input - transaction.root - key) - transaction.inputs + (fun output -> + Sapling.Verification.check_output vctx output) + transaction.outputs in if not pass then (ctxt, None) else let pass = - (* Check the signature and balance of the whole transaction *) - Sapling.Verification.final_check vctx transaction key + (* Check all the input Zk proofs and signatures *) + List.for_all + (fun input -> + Sapling.Verification.check_spend + vctx + input + transaction.root + key) + transaction.inputs in if not pass then (ctxt, None) else - (* update tree *) - let list_to_add = - List.map - (fun output -> - Sapling.UTXO.(output.cm, output.ciphertext)) - transaction.outputs + let pass = + (* Check the signature and balance of the whole transaction *) + Sapling.Verification.final_check vctx transaction key in - let state = Sapling_storage.add state list_to_add in - (ctxt, Some (transaction.balance, state))) + if not pass then (ctxt, None) + else + (* update tree *) + let list_to_add = + List.map + (fun output -> + Sapling.UTXO.(output.cm, output.ciphertext)) + transaction.outputs + in + let state = Sapling_storage.add state list_to_add in + (ctxt, Some (transaction.balance, state))) + else Lwt.return @@ error Internal_errors.Asserted diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index cf88d12bc78a1..c2579b65cb847 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -910,7 +910,9 @@ module Make (Context : P) : let state_hash state = let context_hash = Tree.hash state in - Lwt.return @@ State_hash.context_hash_to_state_hash context_hash + match State_hash.context_hash_to_state_hash context_hash with + | Ok sth -> Lwt.return sth + | Error _ -> assert false (* @TODO remove asserts *) let pp state = let open Lwt_syntax in @@ -1307,7 +1309,11 @@ module Make (Context : P) : | [lvl; slot; page] -> let* lvl = Int32.of_string_opt lvl in let* lvl = Bounded.Non_negative_int32.of_value lvl in - let published_level = Raw_level_repr.of_int32_non_negative lvl in + let published_level = + match Raw_level_repr.of_int32_non_negative lvl with + | Pervasives.Ok published_level -> published_level + | Pervasives.Error _ -> assert false + in let delta = Raw_level_repr.diff current_lvl published_level in (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3995 Putting delta > 0l doesn't work here because of the way the node @@ -1564,7 +1570,10 @@ module Protocol_implementation = Make (struct type tree = Context.tree - let hash_tree t = State_hash.context_hash_to_state_hash (Tree.hash t) + let hash_tree t = + match State_hash.context_hash_to_state_hash (Tree.hash t) with + | Ok sth -> sth + | Error _ -> assert false (* @TODO remove asserts *) type proof = Context.Proof.tree Context.Proof.t @@ -1578,9 +1587,15 @@ module Protocol_implementation = Make (struct let kinded_hash_to_state_hash = function | `Value hash | `Node hash -> State_hash.context_hash_to_state_hash hash - let proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before + let proof_before proof = + match kinded_hash_to_state_hash proof.Context.Proof.before with + | Ok prf -> prf + | Error _ -> assert false (* @TODO remove asserts *) - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after + let proof_after proof = + match kinded_hash_to_state_hash proof.Context.Proof.after with + | Ok prf -> prf + | Error _ -> assert false (* @TODO remove asserts *) let proof_encoding = Context.Proof_encoding.V2.Tree32.tree_proof_encoding end) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml index b01cd33baac4b..b86bc7b8370a4 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml @@ -99,14 +99,16 @@ module V1 = struct (* For [number_of_messages] and [number_of_ticks] min_value is equal to zero. *) let genesis_commitment ~origination_level ~genesis_state_hash = + let open Result_syntax in let open Sc_rollup_repr in let number_of_ticks = Number_of_ticks.zero in - { - compressed_state = genesis_state_hash; - inbox_level = origination_level; - predecessor = Hash.zero; - number_of_ticks; - } + return + { + compressed_state = genesis_state_hash; + inbox_level = origination_level; + predecessor = Hash.zero; + number_of_ticks; + } type genesis_info = {level : Raw_level_repr.t; commitment_hash : Hash.t} diff --git a/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.mli index 0346e476d141c..bcfa11aaf5928 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.mli @@ -85,7 +85,7 @@ module V1 : sig val genesis_commitment : origination_level:Raw_level_repr.t -> genesis_state_hash:Sc_rollup_repr.State_hash.t -> - t + t tzresult (** The genesis of a rollup is characterized by the Tezos level of the rollup origination, and the hash of the commitment computed diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index 1896ae5d2afb8..4be18e8765480 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -458,9 +458,11 @@ module Index = struct let* b_staker = Staker.of_b58check_opt b in Some (make a_staker b_staker) - let of_path = function [a; b] -> both_of_b58check_opt (a, b) | _ -> None + let of_path = function + | [a; b] -> ok @@ both_of_b58check_opt (a, b) + | _ -> ok None - let path_length = 2 + let path_length = ok 2 let rpc_arg = let descr = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli index ac447a1266619..c591322a53ef1 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli @@ -269,9 +269,9 @@ module Index : sig by [i] added as a prefix to path [p]. See [Path_encoding] module. *) val to_path : t -> string list -> string list - val of_path : string list -> t option + val of_path : string list -> t option tzresult - val path_length : int + val path_length : int tzresult val rpc_arg : t RPC_arg.t diff --git a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml index 7506dcbe4f574..8564657d34779 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml @@ -266,7 +266,7 @@ let originate ctxt ~kind ~boot_sector ~origination_proof ~parameters_ty = let* genesis_hash = check_origination_proof kind boot_sector origination_proof in - let genesis_commitment = + let*? genesis_commitment = Sc_rollup.Commitment.genesis_commitment ~genesis_state_hash:genesis_hash ~origination_level:(Level.current ctxt).level diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml index f4accd803d590..91a27b0be4e7e 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -215,27 +215,30 @@ module Dal_proofs = struct *) let page_level_is_valid ~dal_attestation_lag ~origination_level ~commit_level page_id = + let open Result_syntax in (* [dal_attestation_lag] is supposed to be positive. *) let page_published_level = Dal_slot_repr.(page_id.Page.slot_id.Header.published_level) in let open Raw_level_repr in let not_too_old = page_published_level > origination_level in - let not_too_recent = - add page_published_level dal_attestation_lag < commit_level + let* page_published_level_with_lag = + add page_published_level dal_attestation_lag in - not_too_old && not_too_recent + let not_too_recent = page_published_level_with_lag < commit_level in + return (not_too_old && not_too_recent) let verify ~metadata ~dal_attestation_lag ~commit_level dal_parameters page_id dal_snapshot proof = let open Result_syntax in - if + let* is_valid = page_level_is_valid ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level ~dal_attestation_lag ~commit_level page_id - then + in + if is_valid then let* input = Dal_slot_repr.History.verify_proof dal_parameters @@ -249,13 +252,14 @@ module Dal_proofs = struct let produce ~metadata ~dal_attestation_lag ~commit_level dal_parameters page_id ~page_info confirmed_slots_history history_cache = let open Result_syntax in - if + let* is_valid = page_level_is_valid ~origination_level:metadata.Sc_rollup_metadata_repr.origination_level ~dal_attestation_lag ~commit_level page_id - then + in + if is_valid then let* proof, content_opt = Dal_slot_repr.History.produce_proof dal_parameters diff --git a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml index ec88c7fdd560c..cf4d7f12f4193 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml @@ -98,11 +98,13 @@ let goto_inbox_level ctxt rollup inbox_level commit = let* info, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup commit in - if Raw_level_repr.(info.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)) ; - return (commit, ctxt)) + if Raw_level_repr.(info.Commitment.inbox_level <= inbox_level) then + if + (* 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. *) + Raw_level_repr.(info.inbox_level = inbox_level) + then return (commit, ctxt) + else Lwt.return @@ error Internal_errors.Asserted else (go [@ocaml.tailcall]) ctxt info.predecessor in go ctxt commit @@ -164,20 +166,21 @@ let get_conflict_point ctxt rollup staker1 staker2 = - In recursive calls, the commitments are replaced by their respective predecessors, and we know that successive commitments in a branch are spaced by [sc_rollup_commitment_period_in_blocks] *) - assert (Raw_level_repr.(commit1_info.inbox_level = commit2_info.inbox_level)) ; - if Commitment_hash.(commit1_info.predecessor = commit2_info.predecessor) - then - (* Same predecessor means we've found the conflict points. *) - return - ( ( {hash = commit1; commitment = commit1_info}, - {hash = commit2; commitment = commit2_info} ), - ctxt ) - else - (* Different predecessors means they run in parallel. *) - (traverse_in_parallel [@ocaml.tailcall]) - ctxt - commit1_info.predecessor - commit2_info.predecessor + if Raw_level_repr.(commit1_info.inbox_level = commit2_info.inbox_level) then + if Commitment_hash.(commit1_info.predecessor = commit2_info.predecessor) + then + (* Same predecessor means we've found the conflict points. *) + return + ( ( {hash = commit1; commitment = commit1_info}, + {hash = commit2; commitment = commit2_info} ), + ctxt ) + else + (* Different predecessors means they run in parallel. *) + (traverse_in_parallel [@ocaml.tailcall]) + ctxt + commit1_info.predecessor + commit2_info.predecessor + else Lwt.return @@ error Internal_errors.Asserted in let* () = fail_when @@ -329,7 +332,7 @@ let timeout ctxt rollup stakers = let block_left_before_timeout = match game.turn with Alice -> timeout.alice | Bob -> timeout.bob in - let level_of_timeout = + let*? level_of_timeout = Raw_level_repr.add timeout.last_turn_level block_left_before_timeout in fail_unless diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml index 8e55f1da4132c..8e2a564d40b05 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml @@ -90,12 +90,14 @@ module State_hash = struct include Path_encoding.Make_hex (H) - let context_hash_to_state_hash = + let context_hash_to_state_hash h = + let open Result_syntax in (* Both State_hash and Context_hash's hashes are supposed to have the same size. This top-level check enforces this invariant, in which case, no exception could be thrown by [of_bytes_exn] below *) - let () = assert (Compare.Int.equal size Context_hash.size) in - fun h -> of_bytes_exn @@ Context_hash.to_bytes h + if Compare.Int.equal size Context_hash.size then + return @@ of_bytes_exn @@ Context_hash.to_bytes h + else error Internal_errors.Asserted (* Hackish way to disable hash_bytes and hash_string to force people to use context_hash_to_state_hash (without changing content of HASH.S) *) @@ -172,19 +174,20 @@ module Staker = Signature.Public_key_hash module Index = struct type t = Address.t - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in let (`Hex key) = Hex.of_bytes raw_key in key :: l - let of_path = function + let of_path : _ -> _ tzresult = function | [key] -> - Option.bind - (Hex.to_bytes (`Hex key)) - (Data_encoding.Binary.of_bytes_opt encoding) - | _ -> None + ok + @@ Option.bind + (Hex.to_bytes (`Hex key)) + (Data_encoding.Binary.of_bytes_opt encoding) + | _ -> ok None let rpc_arg = rpc_arg @@ -200,8 +203,5 @@ module Number_of_ticks = struct let max_value = Int64.max_int end) - let zero = - match of_value 0L with - | Some zero -> zero - | None -> assert false (* unreachable case, since [min_int = 0l] *) + let zero = match of_value 0L with Some zero -> zero | None -> assert false end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli index 3a7ea11362817..72a05d96eb118 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli @@ -62,7 +62,7 @@ module State_hash : sig (** [context_hash_to_state_hash ch] turns an (Irmin) context hash into a state hash. *) - val context_hash_to_state_hash : Context_hash.t -> t + val context_hash_to_state_hash : Context_hash.t -> t tzresult (* Hackish way to disable hash_bytes and hash_string to force people to use context_hash_to_state_hash (without changing content of HASH.S) *) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml index e86d7bc3ee2a2..8365215457a1c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml @@ -50,8 +50,8 @@ let modify_staker_count ctxt rollup f = let* ctxt, size_diff, _was_bound = Store.Staker_count.add ctxt rollup (f count) in - assert (Compare.Int.(size_diff = 0)) ; - return ctxt + if Compare.Int.(size_diff = 0) then return ctxt + else Lwt.return @@ error Internal_errors.Asserted let get_contract_and_stake ctxt staker = let staker_contract = Contract_repr.Implicit staker in @@ -162,9 +162,9 @@ let assert_commitment_period ctxt rollup commitment = Constants_storage.sc_rollup_commitment_period_in_blocks ctxt in let* () = + let*? res = Raw_level_repr.add pred_level sc_rollup_commitment_period in fail_unless - Raw_level_repr.( - commitment.inbox_level = add pred_level sc_rollup_commitment_period) + Raw_level_repr.(commitment.inbox_level = res) Sc_rollup_bad_inbox_level in return ctxt @@ -309,7 +309,7 @@ let refine_stake ctxt rollup staker staked_on commitment = (* 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 Commitment_hash.(node = staked_on) then (* Previously staked commit found: Insert new commitment if not existing *) let* ctxt, commitment_size_diff, _was_bound = @@ -336,9 +336,9 @@ let refine_stake ctxt rollup staker staked_on commitment = let expected_size_diff = commitment_storage_size_in_bytes in (* First submission adds [commitment_storage_size_in_bytes] to storage. Later submission adds 0 due to content-addressing. *) - assert (Compare.Int.(size_diff = 0 || size_diff = expected_size_diff)) ; - return (new_hash, commitment_added_level, ctxt) - (* See WARNING above. *)) + if Compare.Int.(size_diff = 0 || size_diff = expected_size_diff) then + return (new_hash, commitment_added_level, ctxt) + else Lwt.return @@ error Internal_errors.Asserted (* See WARNING above. *) else let* () = (* We reached the LCC, but [staker] is not staked directly on it. @@ -409,7 +409,7 @@ let cement_commitment ctxt rollup new_lcc = in let* () = let current_level = (Raw_context.current_level ctxt).level in - let min_level = + let*? min_level = Raw_level_repr.add new_lcc_added refutation_deadline_blocks in fail_when diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 4aa6fd08925a3..182cd81437ed9 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -117,10 +117,7 @@ let kind ctxt address = | Some k -> return (ctxt, k) | None -> tzfail (Sc_rollup_errors.Sc_rollup_does_not_exist address) -let list_unaccounted ctxt = - let open Lwt_syntax in - let+ res = Store.PVM_kind.keys_unaccounted ctxt in - Result.return res +let list_unaccounted ctxt = Store.PVM_kind.keys_unaccounted ctxt let genesis_info ctxt rollup = let open Lwt_result_syntax in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index 2f4310f4dbfb9..c22a192bbccba 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -246,7 +246,9 @@ module V2_0_0 = struct let state_hash state = let context_hash = Tree.hash state in - Lwt.return @@ State_hash.context_hash_to_state_hash context_hash + match State_hash.context_hash_to_state_hash context_hash with + | Ok sth -> Lwt.return @@ sth + | Error _ -> assert false (* @TODO remove asserts *) let result_of m state = let open Lwt_syntax in @@ -309,7 +311,10 @@ module V2_0_0 = struct | Waiting_for_input_message -> ( let* last_read = get_last_message_read in match last_read with - | Some (level, n) -> return (PS.First_after (level, n)) + | Some (level, n) -> ( + match level with + | Ok lvl -> return (PS.First_after (lvl, n)) + | Error _ -> assert false (* @TODO remove asserts *)) | None -> return PS.Initial) | Computing -> return PS.No_input_required | Waiting_for_reveal reveal -> return (PS.Needs_reveal reveal) @@ -320,13 +325,14 @@ module V2_0_0 = struct let get_outbox outbox_level state = let outbox_level_int32 = - Raw_level_repr.to_int32_non_negative outbox_level + Internal_errors.ignore_errors + (Raw_level_repr.to_int32_non_negative outbox_level) in - let open Lwt_syntax in let[@coq_struct "message_index"] rec aux outbox message_index = let output = Wasm_2_0_0.{outbox_level = outbox_level_int32; message_index} in + let open Lwt_syntax in let* res = WASM_machine.get_output output state in match res with | None -> return (List.rev outbox) @@ -357,13 +363,15 @@ module V2_0_0 = struct let open PS in let {inbox_level; message_counter; payload} = input in let* s = get in + let inbox_level = + match Raw_level_repr.to_int32_non_negative inbox_level with + | Ok lvl -> lvl + | Error _ -> assert false (* @TODO remove asserts *) + in let* s = lift (WASM_machine.set_input_step - { - inbox_level = Raw_level_repr.to_int32_non_negative inbox_level; - message_counter; - } + {inbox_level; message_counter} (payload :> string) s) in @@ -476,15 +484,13 @@ module V2_0_0 = struct | {outbox_level; message_index; message} -> ( let open Monad.Syntax in let* s = get in + let lvl = + match Raw_level_repr.to_int32_non_negative outbox_level with + | Ok lvl -> lvl + | Error _ -> assert false (* @TODO remove asserts *) + in let* result = - lift - (WASM_machine.get_output - { - outbox_level = - Raw_level_repr.to_int32_non_negative outbox_level; - message_index; - } - s) + lift (WASM_machine.get_output {outbox_level = lvl; message_index} s) in let message_encoded = Data_encoding.Binary.to_string_exn @@ -559,10 +565,14 @@ module V2_0_0 = struct State_hash.context_hash_to_state_hash hash let proof_before proof = - kinded_hash_to_state_hash proof.Context.Proof.before + match kinded_hash_to_state_hash proof.Context.Proof.before with + | Ok sth -> sth + | Error _ -> assert false (* @TODO remove asserts *) let proof_after proof = - kinded_hash_to_state_hash proof.Context.Proof.after + match kinded_hash_to_state_hash proof.Context.Proof.after with + | Ok sth -> sth + | Error _ -> assert false (* @TODO remove asserts *) let proof_encoding = Context.Proof_encoding.V2.Tree32.tree_proof_encoding diff --git a/src/proto_alpha/lib_protocol/script_cache.ml b/src/proto_alpha/lib_protocol/script_cache.ml index ce6e55771ac9f..0db1cb54e9f4a 100644 --- a/src/proto_alpha/lib_protocol/script_cache.ml +++ b/src/proto_alpha/lib_protocol/script_cache.ml @@ -104,9 +104,12 @@ let update ctxt identifier updated_script approx_size = Cache.update ctxt identifier (Some (updated_script, approx_size)) let entries ctxt = - Cache.list_identifiers ctxt - |> List.map_e @@ fun (identifier, age) -> - contract_of_identifier identifier >|? fun contract -> (contract, age) + let open Result_syntax in + let* identifiers = Cache.list_identifiers ctxt in + List.map_e + (fun (identifier, age) -> + contract_of_identifier identifier >|? fun contract -> (contract, age)) + identifiers let contract_rank ctxt addr = Cache.identifier_rank ctxt (identifier_of_contract addr) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 88291491ab24f..5c542724cfbd4 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1911,6 +1911,7 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : s -> (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = fun logger g gas stack_ty k0 ks accu stack -> + let open Lwt_result_syntax in let ty_for_logging_unsafe = function (* This function is only called when logging is enabled. If that's the case, the elaborator must have been called with @@ -1919,8 +1920,8 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : option was omitted, resulting in a crash here. But this is acceptable, because logging is never enabled during block validation, so the layer 1 is safe. *) - | None -> assert false - | Some ty -> ty + | None -> Lwt.return @@ error Internal_errors.Asserted + | Some ty -> return ty in (match ks with | KLog _ -> () @@ -1939,11 +1940,11 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : in (kiter [@ocaml.tailcall]) instrument g gas body xty xs k accu stack | KList_enter_body (body, xs, ys, ty_opt, len, k) -> - let instrument = - let ty = ty_for_logging_unsafe ty_opt in + let* instrument = + let* ty = ty_for_logging_unsafe ty_opt in let (List_t (vty, _)) = ty in let sty = Item_t (vty, stack_ty) in - Script_interpreter_logging.instrument_cont logger sty + return @@ Script_interpreter_logging.instrument_cont logger sty in (klist_enter [@ocaml.tailcall]) instrument @@ -1973,11 +1974,11 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : accu stack | KMap_enter_body (body, xs, ys, ty_opt, k) -> - let instrument = - let ty = ty_for_logging_unsafe ty_opt in + let* instrument = + let* ty = ty_for_logging_unsafe ty_opt in let (Map_t (_, vty, _)) = ty in let sty = Item_t (vty, stack_ty) in - Script_interpreter_logging.instrument_cont logger sty + return @@ Script_interpreter_logging.instrument_cont logger sty in (kmap_enter [@ocaml.tailcall]) instrument diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ee3bfcf2510f5..a0046ee13d1c1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1434,20 +1434,21 @@ 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)) ; - let max_int = (1 lsl nb_bits) - 1 in - let max_z = Z.of_int max_int in - function - | Micheline.Int (_, n) when Compare.Z.(Z.zero <= n) && Compare.Z.(n <= max_z) - -> - ok (Z.to_int n) - | node -> - error - @@ Invalid_syntactic_constant - ( location node, - strip_locations node, - "a positive " ^ string_of_int nb_bits - ^ "-bit integer (between 0 and " ^ string_of_int max_int ^ ")" ) + if Compare.Int.(nb_bits >= 0 && nb_bits <= 30) then + let max_int = (1 lsl nb_bits) - 1 in + let max_z = Z.of_int max_int in + function + | Micheline.Int (_, n) + when Compare.Z.(Z.zero <= n) && Compare.Z.(n <= max_z) -> + ok (Z.to_int n) + | node -> + error + @@ Invalid_syntactic_constant + ( location node, + strip_locations node, + "a positive " ^ string_of_int nb_bits + ^ "-bit integer (between 0 and " ^ string_of_int max_int ^ ")" ) + else fun _ -> error Internal_errors.Asserted let parse_uint10 = parse_uint ~nb_bits:10 @@ -2058,7 +2059,8 @@ let[@coq_struct "ctxt"] rec parse_data_aux : | Operation_t, _ -> (* operations cannot appear in parameters or storage, the protocol should never parse the bytes of an operation *) - assert false + Lwt.return @@ (error [@coq_implicit "a" "(unit * Alpha_context.context)"]) + @@ Internal_errors.Asserted | Chain_id_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr | Address_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr | Tx_rollup_l2_address_t, expr -> diff --git a/src/proto_alpha/lib_protocol/seed_storage.ml b/src/proto_alpha/lib_protocol/seed_storage.ml index 5c3cfc92a7990..1b3d168caf376 100644 --- a/src/proto_alpha/lib_protocol/seed_storage.ml +++ b/src/proto_alpha/lib_protocol/seed_storage.ml @@ -108,7 +108,8 @@ let () = (fun () -> Already_accepted) let purge_nonces_and_get_unrevealed ctxt ~cycle = - let levels = Level_storage.levels_with_commitments_in_cycle ctxt cycle in + let open Lwt_result_syntax in + let*? levels = Level_storage.levels_with_commitments_in_cycle ctxt cycle in let combine (c, unrevealed) level = Storage.Seed.Nonce.get c level >>=? function | Revealed _ -> @@ -121,15 +122,16 @@ let purge_nonces_and_get_unrevealed ctxt ~cycle = List.fold_left_es combine (ctxt, []) levels let compute_randao ctxt = + let open Lwt_result_syntax in let current_cycle = (Level_storage.current ctxt).cycle in let preserved = Constants_storage.preserved_cycles ctxt in - let cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in + let*? cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in let*! seed_computed = Storage.Seed.For_cycle.mem ctxt cycle_computed in (* Check if seed has already been computed, and not in cycle 0. *) match Cycle_repr.(pred current_cycle, pred cycle_computed) with | Some prev_cycle, Some prev_cycle_computed when not seed_computed -> (* Retrieve the levels with nonce commitments in the previous cycle. *) - let levels = + let*? levels = Level_storage.levels_with_commitments_in_cycle ctxt prev_cycle in (* Retrieve previous preserved seed. *) @@ -147,6 +149,7 @@ let compute_randao ctxt = | _, _ -> return ctxt let get_seed_computation_status ctxt = + let open Lwt_result_syntax in let current_level = Level_storage.current ctxt in let current_cycle = current_level.cycle in let nonce_revelation_threshold = @@ -159,8 +162,8 @@ let get_seed_computation_status ctxt = match status with | RANDAO_seed -> let preserved = Constants_storage.preserved_cycles ctxt in - let cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in - let previous_cycle = Cycle_repr.add current_cycle preserved in + let*? cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in + let*? previous_cycle = Cycle_repr.add current_cycle preserved in let* seed_discriminant = Storage.Seed.For_cycle.get ctxt previous_cycle in @@ -208,7 +211,7 @@ let update_seed ctxt vdf_solution = VDF *) let current_cycle = (Level_storage.current ctxt).cycle in let preserved = Constants_storage.preserved_cycles ctxt in - let cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in + let*? cycle_computed = Cycle_repr.add current_cycle (preserved + 1) in let* seed_challenge = Storage.Seed.For_cycle.get ctxt cycle_computed in let new_seed = Seed_repr.vdf_to_seed seed_challenge vdf_solution in Storage.Seed.For_cycle.update ctxt cycle_computed new_seed Seed_repr.VDF_seed @@ -216,18 +219,20 @@ let update_seed ctxt vdf_solution = let raw_for_cycle = Storage.Seed.For_cycle.get let for_cycle ctxt cycle = + let open Lwt_result_syntax in let preserved = Constants_storage.preserved_cycles ctxt in let max_slashing_period = Constants_storage.max_slashing_period ctxt in let current_cycle = (Level_storage.current ctxt).cycle in - let latest = + let*? latest = if Cycle_repr.(current_cycle = root) then Cycle_repr.add current_cycle (preserved + 1) else Cycle_repr.add current_cycle preserved in - let oldest = - match Cycle_repr.sub current_cycle (max_slashing_period - 1) with - | None -> Cycle_repr.root - | Some oldest -> oldest + let* oldest = + let*? res = Cycle_repr.sub current_cycle (max_slashing_period - 1) in + match res with + | None -> return Cycle_repr.root + | Some oldest -> return oldest in let*? () = error_unless diff --git a/src/proto_alpha/lib_protocol/stake_storage.ml b/src/proto_alpha/lib_protocol/stake_storage.ml index 08549fa26a2c5..8a2dd003d6e38 100644 --- a/src/proto_alpha/lib_protocol/stake_storage.ml +++ b/src/proto_alpha/lib_protocol/stake_storage.ml @@ -136,9 +136,9 @@ let set_selected_distribution_for_cycle ctxt cycle stakes total_stake = Selected_distribution_for_cycle.init ctxt cycle stakes >>=? fun ctxt -> Storage.Stake.Total_active_stake.add ctxt cycle total_stake >>= fun ctxt -> (* cleanup snapshots *) - Storage.Stake.Staking_balance.Snapshot.clear ctxt >>= fun ctxt -> + Storage.Stake.Staking_balance.Snapshot.clear ctxt >>=? fun ctxt -> Storage.Stake.Active_delegates_with_minimal_stake.Snapshot.clear ctxt - >>= fun ctxt -> Storage.Stake.Last_snapshot.update ctxt 0 + >>=? fun ctxt -> Storage.Stake.Last_snapshot.update ctxt 0 let clear_cycle ctxt cycle = Storage.Stake.Total_active_stake.remove_existing ctxt cycle >>=? fun ctxt -> @@ -148,9 +148,8 @@ let fold ctxt ~f ~order init = Storage.Stake.Active_delegates_with_minimal_stake.fold ctxt ~order - ~init:(Ok init) + ~init ~f:(fun delegate () acc -> - acc >>?= fun acc -> get_staking_balance ctxt delegate >>=? fun stake -> f (delegate, stake) acc) @@ -165,8 +164,10 @@ let fold_snapshot ctxt ~index ~f ~init = >>=? fun stake -> f (delegate, stake) acc) let clear_at_cycle_end ctxt ~new_cycle = + let open Lwt_result_syntax in let max_slashing_period = Constants_storage.max_slashing_period ctxt in - match Cycle_repr.sub new_cycle max_slashing_period with + let*? res = Cycle_repr.sub new_cycle max_slashing_period in + match res with | None -> return ctxt | Some cycle_to_clear -> clear_cycle ctxt cycle_to_clear diff --git a/src/proto_alpha/lib_protocol/stake_storage.mli b/src/proto_alpha/lib_protocol/stake_storage.mli index 515d001f2f2fe..fe38ef4571216 100644 --- a/src/proto_alpha/lib_protocol/stake_storage.mli +++ b/src/proto_alpha/lib_protocol/stake_storage.mli @@ -104,8 +104,8 @@ val fold_on_active_delegates_with_minimal_stake : Raw_context.t -> order:[`Sorted | `Undefined] -> init:'a -> - f:(Signature.Public_key_hash.t -> unit -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(Signature.Public_key_hash.t -> unit -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t val get_selected_distribution : Raw_context.t -> diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 37a8d377a8630..ca6c666e34355 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -62,11 +62,13 @@ end module Int31_index : INDEX with type t = int = struct type t = int - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = string_of_int c :: l - let of_path = function [] | _ :: _ :: _ -> None | [c] -> int_of_string_opt c + let of_path : _ -> _ tzresult = function + | [] | _ :: _ :: _ -> ok None + | [c] -> ok @@ int_of_string_opt c type 'a ipath = 'a * t @@ -728,11 +730,13 @@ module Sapling = struct let compare = Compare.Int64.compare - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = Int64.to_string c :: l - let of_path = function [c] -> Int64.of_string_opt c | _ -> None + let of_path : _ -> _ tzresult = function + | [c] -> ok @@ Int64.of_string_opt c + | _ -> ok None end)) (Sapling.Hash) @@ -775,11 +779,13 @@ module Sapling = struct let compare = Compare.Int64.compare - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = Int64.to_string c :: l - let of_path = function [c] -> Int64.of_string_opt c | _ -> None + let of_path : _ -> _ tzresult = function + | [c] -> ok @@ Int64.of_string_opt c + | _ -> ok None end)) (Sapling.Ciphertext) @@ -830,11 +836,13 @@ module Sapling = struct let compare = Compare.Int64.compare - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = Int64.to_string c :: l - let of_path = function [c] -> Int64.of_string_opt c | _ -> None + let of_path : _ -> _ tzresult = function + | [c] -> ok @@ Int64.of_string_opt c + | _ -> ok None end)) (Sapling.Nullifier) @@ -871,13 +879,13 @@ module Sapling = struct let compare = Sapling.Nullifier.compare - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = to_string c :: l - let of_path = function - | [c] -> Result.to_option (of_string c) - | _ -> None + let of_path : _ -> _ tzresult = function + | [c] -> ok @@ Result.to_option (of_string c) + | _ -> ok None end)) let nullifiers_init ctx id = @@ -922,11 +930,13 @@ module Sapling = struct let compare = Compare.Int32.compare - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = Int32.to_string c :: l - let of_path = function [c] -> Int32.of_string_opt c | _ -> None + let of_path : _ -> _ tzresult = function + | [c] -> ok @@ Int32.of_string_opt c + | _ -> ok None end)) (Sapling.Hash) @@ -958,27 +968,34 @@ module Public_key_hash = struct | Secp256k1 h -> "secp256k1" :: Path_Secp256k1.to_path h l | P256 h -> "p256" :: Path_P256.to_path h l - let of_path : _ -> public_key_hash option = function - | "ed25519" :: rest -> ( - match Path_Ed25519.of_path rest with - | Some pkh -> Some (Ed25519 pkh) - | None -> None) - | "secp256k1" :: rest -> ( - match Path_Secp256k1.of_path rest with - | Some pkh -> Some (Secp256k1 pkh) - | None -> None) - | "p256" :: rest -> ( - match Path_P256.of_path rest with - | Some pkh -> Some (P256 pkh) - | None -> None) - | _ -> None + let of_path : _ -> public_key_hash option tzresult = function + | "ed25519" :: rest -> + (Path_Ed25519.of_path rest >>? fun rest -> + match rest with + | Some pkh -> ok @@ Some (Ed25519 pkh : public_key_hash) + | None -> ok None + : public_key_hash option tzresult) + | "secp256k1" :: rest -> + (Path_Secp256k1.of_path rest >>? fun rest -> + match rest with + | Some pkh -> ok @@ Some (Secp256k1 pkh : public_key_hash) + | None -> ok None + : public_key_hash option tzresult) + | "p256" :: rest -> + (Path_P256.of_path rest >>? fun rest -> + match rest with + | Some pkh -> ok @@ Some (P256 pkh : public_key_hash) + | None -> ok None + : public_key_hash option tzresult) + | _ -> ok None let path_length = - let l1 = Path_Ed25519.path_length - and l2 = Path_Secp256k1.path_length - and l3 = Path_P256.path_length in - assert (Compare.Int.(l1 = l2 && l2 = l3)) ; - l1 + 1 + let open Result_syntax in + let* l1 = Path_Ed25519.path_length in + let* l2 = Path_Secp256k1.path_length in + let* l3 = Path_P256.path_length in + if Compare.Int.(l1 = l2 && l2 = l3) then return @@ (l1 + 1) + else error Internal_errors.Asserted end module Public_key_hash_index = Make_index (Public_key_hash) @@ -2035,11 +2052,13 @@ module Sc_rollup = struct let compare = Compare.Int32.compare - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = Int32.to_string c :: l - let of_path = function [c] -> Int32.of_string_opt c | _ -> None + let of_path : _ -> _ tzresult = function + | [c] -> ok @@ Int32.of_string_opt c + | _ -> ok None end module Level_index_context = @@ -2198,11 +2217,13 @@ module Zk_rollup = struct let compare = Compare.Int64.compare - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = Int64.to_string c :: l - let of_path = function [c] -> Int64.of_string_opt c | _ -> None + let of_path : _ -> _ tzresult = function + | [c] -> ok @@ Int64.of_string_opt c + | _ -> ok None end)) (struct type t = Zk_rollup_operation_repr.t * Ticket_hash_repr.t option diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index 48af01ef32802..ec2651cdec768 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -65,10 +65,10 @@ module Contract : sig Raw_context.t -> order:[`Sorted | `Undefined] -> init:'a -> - f:(Contract_repr.t -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(Contract_repr.t -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t - val list : Raw_context.t -> Contract_repr.t list Lwt.t + val list : Raw_context.t -> Contract_repr.t list tzresult Lwt.t (** see {!Raw_context_intf.T.local_context} *) type local_context @@ -220,8 +220,8 @@ module Contract : sig Raw_context.t * Contract_repr.t -> order:[`Sorted | `Undefined] -> init:'a -> - f:(Bond_id_repr.t -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(Bond_id_repr.t -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t (** Associates a contract with the total of all its frozen bonds. *) module Total_frozen_bonds : @@ -245,10 +245,10 @@ module Big_map : sig Raw_context.t -> order:[`Sorted | `Undefined] -> init:'a -> - f:(id -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(id -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t - val list : Raw_context.t -> id list Lwt.t + val list : Raw_context.t -> id list tzresult Lwt.t val remove : Raw_context.t -> id -> Raw_context.t Lwt.t diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index 99cc9b6f866e9..e24e4b561a523 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -216,17 +216,25 @@ end module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t = struct type t = I1.t * I2.t - let path_length = I1.path_length + I2.path_length + let path_length = + let open Result_syntax in + let* p1 = I1.path_length in + let* p2 = I2.path_length in + return @@ (p1 + p2) let to_path (x, y) l = I1.to_path x (I2.to_path y l) let of_path l = - match Misc.take I1.path_length l with - | None -> None + I1.path_length >>? fun pl -> + match Misc.take pl l with + | None -> ok None | Some (l1, l2) -> ( - match (I1.of_path l1, I2.of_path l2) with - | Some x, Some y -> Some (x, y) - | _ -> None) + let open Result_syntax in + let* opl1 = I1.of_path l1 in + let* opl2 = I2.of_path l2 in + match (opl1, opl2) with + | Some x, Some y -> ok @@ Some (x, y) + | _ -> ok None) type 'a ipath = 'a I1.ipath I2.ipath @@ -249,19 +257,32 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : let remove s i = C.remove s (I.to_path i []) >|= fun t -> C.project t - let clear s = C.remove s [] >|= fun t -> C.project t + let clear s = C.remove s [] >|= fun t -> ok @@ C.project t let fold s ~order ~init ~f = - C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc -> + let open Lwt_result_syntax in + let*? path_length = I.path_length in + C.fold + ~depth:(`Eq path_length) + s + [] + ~order + ~init:(ok init) + ~f:(fun file tree acc -> + let open Lwt_result_syntax in match C.Tree.kind tree with | `Value -> ( - match I.of_path file with + let*? of_path = I.of_path file in + match of_path with | None -> Lwt.return acc - | Some p -> f p acc) + | Some p -> + let*? acc = acc in + let* res = f p acc in + return res) | `Tree -> Lwt.return acc) let elements s = - fold s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + fold s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return @@ ok (p :: acc)) let () = let open Storage_description in @@ -270,10 +291,7 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : ~get:(fun c -> let c, k = unpack c in mem c k >>= function true -> return_some true | false -> return_none) - (register_indexed_subcontext - ~list:(fun c -> elements c >|= ok) - C.description - I.args) + (register_indexed_subcontext ~list:elements C.description I.args) Data_encoding.bool [@@coq_axiom_with_reason "stack overflow in Coq"] end @@ -322,18 +340,30 @@ struct let remove_existing s i = C.remove_existing s (I.to_path i []) >|=? fun t -> C.project t - let clear s = C.remove s [] >|= fun t -> C.project t + let clear s = C.remove s [] >|= fun t -> ok @@ C.project t let fold s ~order ~init ~f = - C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc -> + let open Lwt_result_syntax in + let*? path_length = I.path_length in + C.fold + ~depth:(`Eq path_length) + s + [] + ~order + ~init:(ok init) + ~f:(fun file tree acc -> C.Tree.to_value tree >>= function | Some v -> ( - match I.of_path file with + let*? of_path = I.of_path file in + match of_path with | None -> Lwt.return acc | Some path -> ( let key () = C.absolute_key s file in match of_bytes ~key v with - | Ok v -> f path v acc + | Ok v -> + let*? acc = acc in + let* res = f path v acc in + return res | Error _ -> Lwt.return acc)) | None -> Lwt.return acc) @@ -342,10 +372,11 @@ struct let bindings s = fold s ~order:`Sorted ~init:[] ~f:(fun p v acc -> - Lwt.return ((p, v) :: acc)) + Lwt.return @@ ok ((p, v) :: acc)) let keys s = - fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc -> + Lwt.return @@ ok (p :: acc)) let () = let open Storage_description in @@ -354,10 +385,7 @@ struct ~get:(fun c -> let c, k = unpack c in find c k) - (register_indexed_subcontext - ~list:(fun c -> keys c >|= ok) - C.description - I.args) + (register_indexed_subcontext ~list:keys C.description I.args) V.encoding [@@coq_axiom_with_reason "stack overflow in Coq"] end @@ -481,8 +509,10 @@ module Make_indexed_carbonated_data_storage_INTERNAL [offset] is passed. *) let list_key_values ?(offset = 0) ?(length = max_int) s = + let open Lwt_result_syntax in let root = [] in - let depth = `Eq I.path_length in + let*? path_length = I.path_length in + let depth = `Eq path_length in C.length s root >>= fun size -> (* Regardless of the [length] argument, all elements stored in the context are traversed. We therefore pay a gas cost proportional to the number of @@ -507,7 +537,8 @@ module Make_indexed_carbonated_data_storage_INTERNAL Lwt.return (Ok (s, rev_values, offset, length)) else (* Nominal case *) - match I.of_path file with + let*? of_path = I.of_path file in + match of_path with | None -> Lwt.return acc | Some key -> (* This also accounts for gas for loading the element. *) @@ -522,12 +553,14 @@ module Make_indexed_carbonated_data_storage_INTERNAL (C.project s, List.rev rev_values) let fold_keys_unaccounted s ~order ~init ~f = + let open Lwt_result_syntax in + let*? path_length = I.path_length in C.fold - ~depth:(`Eq (1 + I.path_length)) + ~depth:(`Eq (1 + path_length)) s [] ~order - ~init + ~init:(ok init) ~f:(fun file tree acc -> match C.Tree.kind tree with | `Value -> ( @@ -535,9 +568,13 @@ module Make_indexed_carbonated_data_storage_INTERNAL | last :: _ when Compare.String.(last = len_name) -> Lwt.return acc | last :: rest when Compare.String.(last = data_name) -> ( let file = List.rev rest in - match I.of_path file with + let*? of_path = I.of_path file in + match of_path with | None -> Lwt.return acc - | Some path -> f path acc) + | Some path -> + let*? acc = acc in + let*! res = f path acc in + return res) | _ -> Lwt.return acc) | `Tree -> Lwt.return acc) @@ -552,10 +589,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL ~get:(fun c -> let c, k = unpack c in find c k >|=? fun (_, v) -> v) - (register_indexed_subcontext - ~list:(fun c -> keys_unaccounted c >|= ok) - C.description - I.args) + (register_indexed_subcontext ~list:keys_unaccounted C.description I.args) V.encoding [@@coq_axiom_with_reason "stack overflow in Coq"] end @@ -647,9 +681,11 @@ module Make_indexed_data_snapshotable_storage C.find_tree s (snapshot_path id) >>= function | None -> Lwt.return (err_missing_key data_name) | Some tree -> + let open Lwt_result_syntax in + let*? path_length = I.path_length in C_data.Tree.fold tree - ~depth:(`Eq I.path_length) + ~depth:(`Eq path_length) [] ~order ~init:(Ok init) @@ -657,7 +693,8 @@ module Make_indexed_data_snapshotable_storage acc >>?= fun acc -> C.Tree.to_value tree >>= function | Some v -> ( - match I.of_path file with + let*? of_path = I.of_path file in + match of_path with | None -> return acc | Some path -> ( let key () = C.absolute_key s file in @@ -689,16 +726,29 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let clear t = C.remove t [] >|= fun t -> C.project t let fold_keys t ~order ~init ~f = - C.fold ~depth:(`Eq I.path_length) t [] ~order ~init ~f:(fun path tree acc -> + let open Lwt_result_syntax in + let*? path_length = I.path_length in + C.fold + ~depth:(`Eq path_length) + t + [] + ~order + ~init:(ok init) + ~f:(fun path tree acc -> match C.Tree.kind tree with | `Tree -> ( - match I.of_path path with + let*? of_path = I.of_path path in + match of_path with | None -> Lwt.return acc - | Some path -> f path acc) + | Some path -> + let*? acc = acc in + let* res = f path acc in + return res) | `Value -> Lwt.return acc) let keys t = - fold_keys t ~order:`Sorted ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc)) + fold_keys t ~order:`Sorted ~init:[] ~f:(fun i acc -> + Lwt.return @@ ok (i :: acc)) let err_missing_key key = Raw_context.storage_error (Missing_key (key, Copy)) @@ -713,7 +763,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let description = Storage_description.register_indexed_subcontext - ~list:(fun c -> keys c >|= ok) + ~list:keys C.description I.args @@ -889,15 +939,16 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : fold_keys s ~init:s ~order:`Sorted ~f:(fun i s -> Raw_context.remove (pack s i) N.name >|= fun c -> let s, _ = unpack c in - s) - >|= fun t -> C.project t + ok s) + >|=? fun t -> C.project t let fold s ~order ~init ~f = fold_keys s ~order ~init ~f:(fun i acc -> - mem s i >>= function true -> f i acc | false -> Lwt.return acc) + mem s i >>= function true -> f i acc | false -> Lwt.return @@ ok acc) let elements s = - fold s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + fold s ~order:`Sorted ~init:[] ~f:(fun p acc -> + Lwt.return @@ ok (p :: acc)) let () = let open Storage_description in @@ -982,24 +1033,26 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : fold_keys s ~order:`Sorted ~init:s ~f:(fun i s -> Raw_context.remove (pack s i) N.name >|= fun c -> let s, _ = unpack c in - s) - >|= fun t -> C.project t + ok s) + >|=? fun t -> C.project t let fold s ~order ~init ~f = fold_keys s ~order ~init ~f:(fun i acc -> - get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc) + get s i >>= function + | Error _ -> Lwt.return @@ ok acc + | Ok v -> f i v acc) let bindings s = fold s ~order:`Sorted ~init:[] ~f:(fun p v acc -> - Lwt.return ((p, v) :: acc)) + Lwt.return @@ ok ((p, v) :: acc)) let fold_keys s ~order ~init ~f = fold_keys s ~order ~init ~f:(fun i acc -> - mem s i >>= function false -> Lwt.return acc | true -> f i acc) + mem s i >>= function false -> Lwt.return @@ ok acc | true -> f i acc) let keys s = fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc -> - Lwt.return (p :: acc)) + Lwt.return @@ ok (p :: acc)) let () = let open Storage_description in @@ -1165,12 +1218,12 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : let fold_keys_unaccounted s ~order ~init ~f = fold_keys s ~order ~init ~f:(fun i acc -> mem_unaccounted s i >>= function - | false -> Lwt.return acc + | false -> Lwt.return @@ ok acc | true -> f i acc) let keys_unaccounted s = fold_keys_unaccounted s ~order:`Sorted ~init:[] ~f:(fun p acc -> - Lwt.return (p :: acc)) + Lwt.return @@ ok (p :: acc)) let () = let open Storage_description in @@ -1236,16 +1289,19 @@ module Wrap_indexed_data_storage let fold ctxt ~order ~init ~f = C.fold ctxt ~order ~init ~f:(fun k v acc -> - match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc) + match K.unwrap k with + | None -> Lwt.return @@ ok acc + | Some k -> f k v acc) let bindings s = fold s ~order:`Sorted ~init:[] ~f:(fun p v acc -> - Lwt.return ((p, v) :: acc)) + Lwt.return @@ ok ((p, v) :: acc)) let fold_keys s ~order ~init ~f = C.fold_keys s ~order ~init ~f:(fun k acc -> - match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc) + match K.unwrap k with None -> Lwt.return @@ ok acc | Some k -> f k acc) let keys s = - fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc)) + fold_keys s ~order:`Sorted ~init:[] ~f:(fun p acc -> + Lwt.return @@ ok (p :: acc)) end diff --git a/src/proto_alpha/lib_protocol/storage_sigs.ml b/src/proto_alpha/lib_protocol/storage_sigs.ml index 2e370236923ef..5563fcccbd86c 100644 --- a/src/proto_alpha/lib_protocol/storage_sigs.ml +++ b/src/proto_alpha/lib_protocol/storage_sigs.ml @@ -214,7 +214,7 @@ module type Non_iterable_indexed_carbonated_data_storage = sig (** Returns the list of all storage bucket keys. Not carbonated (i.e. gas is not consumed); use with care. *) - val keys_unaccounted : context -> key list Lwt.t + val keys_unaccounted : context -> key list tzresult Lwt.t end [@@coq_precise_signature] @@ -244,7 +244,7 @@ module type Indexed_carbonated_data_storage_INTERNAL = sig order:[`Sorted | `Undefined] -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + 'a tzresult Lwt.t end (** The generic signature of indexed data accessors (a set of values @@ -254,29 +254,29 @@ module type Indexed_data_storage = sig include Non_iterable_indexed_data_storage (** Empties all the keys and associated data. *) - val clear : context -> Raw_context.t Lwt.t + val clear : context -> Raw_context.t tzresult Lwt.t (** Lists all the keys. *) - val keys : context -> key list Lwt.t + val keys : context -> key list tzresult Lwt.t (** Lists all the keys and associated data. *) - val bindings : context -> (key * value) list Lwt.t + val bindings : context -> (key * value) list tzresult Lwt.t (** Iterates over all the keys and associated data. *) val fold : context -> order:[`Sorted | `Undefined] -> init:'a -> - f:(key -> value -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(key -> value -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t (** Iterate over all the keys. *) val fold_keys : context -> order:[`Sorted | `Undefined] -> init:'a -> - f:(key -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(key -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t end module type Indexed_data_storage_with_local_context_Local = sig @@ -389,18 +389,18 @@ module type Data_set_storage = sig (** Returns the elements of the set, deserialized in a list in no particular order. *) - val elements : context -> elt list Lwt.t + val elements : context -> elt list tzresult Lwt.t (** Iterates over the elements of the set. *) val fold : context -> order:[`Sorted | `Undefined] -> init:'a -> - f:(elt -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(elt -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t (** Removes all elements in the set *) - val clear : context -> Raw_context.t Lwt.t + val clear : context -> Raw_context.t tzresult Lwt.t end (** Variant of {!Data_set_storage} with gas accounting. *) @@ -437,7 +437,7 @@ module type Carbonated_data_set_storage = sig order:[`Sorted | `Undefined] -> init:'acc -> f:(elt -> 'acc -> 'acc Lwt.t) -> - 'acc Lwt.t + 'acc tzresult Lwt.t end module type NAME = sig @@ -471,10 +471,10 @@ module type Indexed_raw_context = sig context -> order:[`Sorted | `Undefined] -> init:'a -> - f:(key -> 'a -> 'a Lwt.t) -> - 'a Lwt.t + f:(key -> 'a -> 'a tzresult Lwt.t) -> + 'a tzresult Lwt.t - val keys : context -> key list Lwt.t + val keys : context -> key list tzresult Lwt.t val remove : context -> key -> context Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index dab412eac584f..1253073e1be75 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -1009,12 +1009,12 @@ let bake_until_cycle_end ?policy b = let bake_until_n_cycle_end ?policy n b = List.fold_left_es (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n) -let current_cycle b = - get_constants b >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} -> - let current_level = b.header.shell.level in - let current_cycle = Int32.div current_level blocks_per_cycle in - let current_cycle = Cycle.add Cycle.root (Int32.to_int current_cycle) in - return current_cycle +let current_cycle _ = assert false +(* get_constants b >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} -> *) +(* let current_level = b.header.shell.level in *) +(* let current_cycle = assert false (\* Int32.div current_level blocks_per_cycle in *\) *) +(* let current_cycle = Cycle.add Cycle.root (Int32.to_int current_cycle) in *) +(* return current_cycle *) let bake_until_cycle ?policy cycle (b : t) = let rec loop (b : t) = diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 1cf523719e416..7c17c3934039d 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -50,7 +50,8 @@ let level st = st.header.shell.level let alpha_ctxt {state = _, application_state; _} = application_state.ctxt -let rpc_context st = +let rpc_context _st = assert false +(* let fitness = (header st).shell.fitness in let result = Alpha_context.finalize (alpha_ctxt st) fitness in { @@ -58,6 +59,7 @@ let rpc_context st = block_header = {st.header.shell with fitness = result.fitness}; context = result.context; } +*) let rpc_ctxt = new Environment.proto_rpc_context_of_directory diff --git a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml index 0f256cd31ce01..39b7d20655f46 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml @@ -181,116 +181,116 @@ module Alpha_context_helpers = struct (ctx, id) (* disk only version *) - let verify_update ctx ?memo_size ?id vt = - let anti_replay = "anti-replay" in - (match id with - | None -> - (match memo_size with - | None -> ( - match vt.Environment.Sapling.UTXO.outputs with - | [] -> failwith "Can't infer memo_size from empty outputs" - | output :: _ -> - return - @@ Environment.Sapling.Ciphertext.get_memo_size - output.ciphertext) - | Some memo_size -> return memo_size) - >>=? fun memo_size -> - let memo_size = memo_size_of_int memo_size in - let vs = Alpha_context.Sapling.empty_state ~memo_size () in - return (vs, ctx) - | Some id -> - (* Storage.Sapling.Roots.get (Obj.magic ctx, id) 0l *) - (* >>= wrap *) - (* >>=? fun (_, root) -> *) - (* print ~prefix:"verify: " Environment.Sapling.Hash.encoding root ; *) - Alpha_context.Sapling.state_from_id ctx id >>= wrap) - >>=? fun (vs, ctx) -> - Alpha_context.Sapling.verify_update ctx vs vt anti_replay >>= wrap - >>=? fun (ctx, res) -> - match res with - | None -> return_none - | Some (_balance, vs) -> - finalize ctx vs >>=? fun (ctx, id) -> - let fake_fitness = - Alpha_context.( - let level = - match Raw_level.of_int32 0l with - | Error _ -> assert false - | Ok l -> l - in - Fitness.create_without_locked_round - ~level - ~predecessor_round:Round.zero - ~round:Round.zero - |> Fitness.to_raw) - in - let ectx = (Alpha_context.finalize ctx fake_fitness).context in - (* bump the level *) - Alpha_context.prepare - ectx - ~level: - Alpha_context.( - Raw_level.to_int32 Level.((succ ctx (current ctx)).level)) - ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) - ~timestamp:(Time.Protocol.of_seconds Int64.zero) - >>= wrap - >|=? fun (ctx, _, _) -> Some (ctx, id) + (* let verify_update ctx ?memo_size ?id vt = *) + (* let anti_replay = "anti-replay" in *) + (* (match id with *) + (* | None -> *) + (* (match memo_size with *) + (* | None -> ( *) + (* match vt.Environment.Sapling.UTXO.outputs with *) + (* | [] -> failwith "Can't infer memo_size from empty outputs" *) + (* | output :: _ -> *) + (* return *) + (* @@ Environment.Sapling.Ciphertext.get_memo_size *) + (* output.ciphertext) *) + (* | Some memo_size -> return memo_size) *) + (* >>=? fun memo_size -> *) + (* let memo_size = memo_size_of_int memo_size in *) + (* let vs = Alpha_context.Sapling.empty_state ~memo_size () in *) + (* return (vs, ctx) *) + (* | Some id -> *) + (* (\* Storage.Sapling.Roots.get (Obj.magic ctx, id) 0l *\) *) + (* (\* >>= wrap *\) *) + (* (\* >>=? fun (_, root) -> *\) *) + (* (\* print ~prefix:"verify: " Environment.Sapling.Hash.encoding root ; *\) *) + (* Alpha_context.Sapling.state_from_id ctx id >>= wrap) *) + (* >>=? fun (vs, ctx) -> *) + (* Alpha_context.Sapling.verify_update ctx vs vt anti_replay >>= wrap *) + (* >>=? fun (ctx, res) -> *) + (* match res with *) + (* | None -> return_none *) + (* | Some (_balance, vs) -> *) + (* finalize ctx vs >>=? fun (ctx, id) -> *) + (* let fake_fitness = *) + (* Alpha_context.( *) + (* let level = *) + (* match Raw_level.of_int32 0l with *) + (* | Error _ -> assert false *) + (* | Ok l -> l *) + (* in *) + (* Fitness.create_without_locked_round *) + (* ~level *) + (* ~predecessor_round:Round.zero *) + (* ~round:Round.zero *) + (* |> Fitness.to_raw) *) + (* in *) + (* let ectx = (Alpha_context.finalize ctx fake_fitness).context in *) + (* (\* bump the level *\) *) + (* Alpha_context.prepare *) + (* ectx *) + (* ~level: *) + (* Alpha_context.( *) + (* Raw_level.to_int32 Level.((succ ctx (current ctx)).level)) *) + (* ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) *) + (* ~timestamp:(Time.Protocol.of_seconds Int64.zero) *) + (* >>= wrap *) + (* >|=? fun (ctx, _, _) -> Some (ctx, id) *) (* Same as before but for legacy *) - let verify_update_legacy ctx ?memo_size ?id vt = - let anti_replay = "anti-replay" in - (match id with - | None -> - (match memo_size with - | None -> ( - match vt.Environment.Sapling.UTXO.Legacy.outputs with - | [] -> failwith "Can't infer memo_size from empty outputs" - | output :: _ -> - return - @@ Environment.Sapling.Ciphertext.get_memo_size - output.ciphertext) - | Some memo_size -> return memo_size) - >>=? fun memo_size -> - let memo_size = memo_size_of_int memo_size in - let vs = Alpha_context.Sapling.empty_state ~memo_size () in - return (vs, ctx) - | Some id -> - (* Storage.Sapling.Roots.get (Obj.magic ctx, id) 0l *) - (* >>= wrap *) - (* >>=? fun (_, root) -> *) - (* print ~prefix:"verify: " Environment.Sapling.Hash.encoding root ; *) - Alpha_context.Sapling.state_from_id ctx id >>= wrap) - >>=? fun (vs, ctx) -> - Alpha_context.Sapling.Legacy.verify_update ctx vs vt anti_replay >>= wrap - >>=? fun (ctx, res) -> - match res with - | None -> return_none - | Some (_balance, vs) -> - finalize ctx vs >>=? fun (ctx, id) -> - let fake_fitness = - Alpha_context.( - let level = - match Raw_level.of_int32 0l with - | Error _ -> assert false - | Ok l -> l - in - Fitness.create_without_locked_round - ~level - ~predecessor_round:Round.zero - ~round:Round.zero - |> Fitness.to_raw) - in - let ectx = (Alpha_context.finalize ctx fake_fitness).context in - (* bump the level *) - Alpha_context.prepare - ectx - ~level: - Alpha_context.( - Raw_level.to_int32 Level.((succ ctx (current ctx)).level)) - ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) - ~timestamp:(Time.Protocol.of_seconds Int64.zero) - >>= wrap - >|=? fun (ctx, _, _) -> Some (ctx, id) + (* let verify_update_legacy ctx ?memo_size ?id vt = *) + (* let anti_replay = "anti-replay" in *) + (* (match id with *) + (* | None -> *) + (* (match memo_size with *) + (* | None -> ( *) + (* match vt.Environment.Sapling.UTXO.Legacy.outputs with *) + (* | [] -> failwith "Can't infer memo_size from empty outputs" *) + (* | output :: _ -> *) + (* return *) + (* @@ Environment.Sapling.Ciphertext.get_memo_size *) + (* output.ciphertext) *) + (* | Some memo_size -> return memo_size) *) + (* >>=? fun memo_size -> *) + (* let memo_size = memo_size_of_int memo_size in *) + (* let vs = Alpha_context.Sapling.empty_state ~memo_size () in *) + (* return (vs, ctx) *) + (* | Some id -> *) + (* (\* Storage.Sapling.Roots.get (Obj.magic ctx, id) 0l *\) *) + (* (\* >>= wrap *\) *) + (* (\* >>=? fun (_, root) -> *\) *) + (* (\* print ~prefix:"verify: " Environment.Sapling.Hash.encoding root ; *\) *) + (* Alpha_context.Sapling.state_from_id ctx id >>= wrap) *) + (* >>=? fun (vs, ctx) -> *) + (* Alpha_context.Sapling.Legacy.verify_update ctx vs vt anti_replay >>= wrap *) + (* >>=? fun (ctx, res) -> *) + (* match res with *) + (* | None -> return_none *) + (* | Some (_balance, vs) -> *) + (* finalize ctx vs >>=? fun (ctx, id) -> *) + (* let fake_fitness = *) + (* Alpha_context.( *) + (* let level = *) + (* match Raw_level.of_int32 0l with *) + (* | Error _ -> assert false *) + (* | Ok l -> l *) + (* in *) + (* Fitness.create_without_locked_round *) + (* ~level *) + (* ~predecessor_round:Round.zero *) + (* ~round:Round.zero *) + (* |> Fitness.to_raw) *) + (* in *) + (* let ectx = (Alpha_context.finalize ctx fake_fitness).context in *) + (* (\* bump the level *\) *) + (* Alpha_context.prepare *) + (* ectx *) + (* ~level: *) + (* Alpha_context.( *) + (* Raw_level.to_int32 Level.((succ ctx (current ctx)).level)) *) + (* ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) *) + (* ~timestamp:(Time.Protocol.of_seconds Int64.zero) *) + (* >>= wrap *) + (* >|=? fun (ctx, _, _) -> Some (ctx, id) *) let transfer_inputs_outputs w cs is = (* Tezos_sapling.Storage.size cs *) diff --git a/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml index 6d9fa91799c37..97248fc9db83f 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml @@ -69,13 +69,15 @@ module In_memory_context = struct return (Some p) | None -> return None - let kinded_hash_to_state_hash = function - | `Value hash | `Node hash -> - Sc_rollup.State_hash.context_hash_to_state_hash hash + (* let kinded_hash_to_state_hash = function *) + (* | `Value hash | `Node hash -> *) + (* Sc_rollup.State_hash.context_hash_to_state_hash hash *) - let proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before + let proof_before _ = + assert false (* kinded_hash_to_state_hash proof.Context.Proof.before *) - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after + let proof_after _ = + assert false (* kinded_hash_to_state_hash proof.Context.Proof.after *) let proof_encoding = Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V2.Tree32 @@ -160,7 +162,7 @@ let genesis_commitment ~boot_sector ~origination_level = function genesis_commitment ~origination_level ~genesis_state_hash) let genesis_commitment_raw ~boot_sector ~origination_level kind = - let open Lwt_syntax in + let open Lwt_result_syntax in let origination_level = Raw_level_repr.to_int32 origination_level |> Alpha_context.Raw_level.of_int32_exn diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml index 2069bccb19594..05845b3d3999c 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml @@ -199,19 +199,20 @@ end module Index = struct type t = Hash.t - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn Hash.encoding c in let (`Hex key) = Hex.of_bytes raw_key in key :: l - let of_path = function + let of_path : _ -> _ tzresult = function | [key] -> - Option.bind - (Hex.to_bytes (`Hex key)) - (Data_encoding.Binary.of_bytes_opt Hash.encoding) - | _ -> None + ok + @@ Option.bind + (Hex.to_bytes (`Hex key)) + (Data_encoding.Binary.of_bytes_opt Hash.encoding) + | _ -> ok None let rpc_arg = Hash.rpc_arg diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml index 35cf8345427b3..a3840f3f54a2e 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml @@ -277,6 +277,7 @@ let has_bond : >|=? fun (ctxt, pending) -> (ctxt, Option.is_some pending) let finalize_commitment ctxt rollup state = + let open Lwt_result_syntax in match Tx_rollup_state_repr.next_commitment_to_finalize state with | Some oldest_inbox_level -> (* Since the commitment head is not null, we know the oldest @@ -285,10 +286,8 @@ let finalize_commitment ctxt rollup state = (* Is the finality period for this commitment over? *) let finality_period = Constants_storage.tx_rollup_finality_period ctxt in let current_level = (Raw_context.current_level ctxt).level in - fail_when - Raw_level_repr.( - current_level < add commitment.submitted_at finality_period) - No_commitment_to_finalize + let*? res = Raw_level_repr.add commitment.submitted_at finality_period in + fail_when Raw_level_repr.(current_level < res) No_commitment_to_finalize >>=? fun () -> (* We remove the inbox *) Tx_rollup_inbox_storage.remove ctxt oldest_inbox_level rollup @@ -307,6 +306,7 @@ let finalize_commitment ctxt rollup state = | None -> tzfail No_commitment_to_finalize let remove_commitment ctxt rollup state = + let open Lwt_result_syntax in match Tx_rollup_state_repr.next_commitment_to_remove state with | Some tail -> (* We check the commitment is old enough *) @@ -317,8 +317,9 @@ let remove_commitment ctxt rollup state = Constants_storage.tx_rollup_withdraw_period ctxt in let current_level = (Raw_context.current_level ctxt).level in + let*? res = Raw_level_repr.add finalized_at withdraw_period in fail_when - Raw_level_repr.(current_level < add finalized_at withdraw_period) + Raw_level_repr.(current_level < res) Remove_commitment_too_early | None -> (* unreachable code if the implementation is correct *) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_level_repr.mli b/src/proto_alpha/lib_protocol/tx_rollup_level_repr.mli index b1ad65ce3d502..3a8a98413bc6b 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_level_repr.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_level_repr.mli @@ -54,9 +54,9 @@ val succ : level -> level val pred : level -> level option (** [add l i] i must be positive *) -val add : level -> int -> level +val add : level -> int -> level tzresult (** [sub l i] i must be positive *) -val sub : level -> int -> level option +val sub : level -> int -> level option tzresult module Index : Storage_description.INDEX with type t = level diff --git a/src/proto_alpha/lib_protocol/tx_rollup_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_repr.ml index 5e4416e669825..a3bbdf4b7642a 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_repr.ml @@ -131,19 +131,20 @@ let rpc_arg = module Index = struct type nonrec t = t - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in let (`Hex key) = Hex.of_bytes raw_key in key :: l - let of_path = function + let of_path : _ -> _ tzresult = function | [key] -> - Option.bind - (Hex.to_bytes (`Hex key)) - (Data_encoding.Binary.of_bytes_opt encoding) - | _ -> None + ok + @@ Option.bind + (Hex.to_bytes (`Hex key)) + (Data_encoding.Binary.of_bytes_opt encoding) + | _ -> ok @@ None let rpc_arg = rpc_arg diff --git a/src/proto_alpha/lib_protocol/validate.ml b/src/proto_alpha/lib_protocol/validate.ml index b50a471246f5b..5eafa2b228a7d 100644 --- a/src/proto_alpha/lib_protocol/validate.ml +++ b/src/proto_alpha/lib_protocol/validate.ml @@ -826,7 +826,7 @@ module Consensus = struct (consensus_content : consensus_content) = let open Lwt_result_syntax in let kind = Grandparent_endorsement in - let level = Level.from_raw vi.ctxt consensus_content.level in + let*? level = Level.from_raw vi.ctxt consensus_content.level in let* (_ctxt : t), consensus_key = Stake_distribution.slot_owner vi.ctxt level consensus_content.slot in @@ -1261,7 +1261,11 @@ module Voting = struct let check_count ~count_in_ctxt ~proposals_length = (* The proposal count of the proposer in the context should never have been increased above [max_proposals_per_delegate]. *) - assert (Compare.Int.(count_in_ctxt <= Constants.max_proposals_per_delegate)) ; + let open Result_syntax in + let* _ = + Internal_errors.do_assert + Compare.Int.(count_in_ctxt <= Constants.max_proposals_per_delegate) + in error_unless Compare.Int.( count_in_ctxt + proposals_length <= Constants.max_proposals_per_delegate) @@ -1599,9 +1603,10 @@ module Anonymous = struct let check_denunciation_age vi kind given_level = let open Result_syntax in let current_cycle = vi.current_level.cycle in - let given_cycle = (Level.from_raw vi.ctxt given_level).cycle in + let* res = Level.from_raw vi.ctxt given_level in + let given_cycle = res.cycle in let max_slashing_period = Constants.max_slashing_period vi.ctxt in - let last_slashable_cycle = Cycle.add given_cycle max_slashing_period in + let* last_slashable_cycle = Cycle.add given_cycle max_slashing_period in let* () = error_unless Cycle.(given_cycle <= current_cycle) @@ -1639,7 +1644,7 @@ module Anonymous = struct (Invalid_denunciation denunciation_kind) in (* Disambiguate: levels are equal *) - let level = Level.from_raw vi.ctxt e1.level in + let*? level = Level.from_raw vi.ctxt e1.level in let*? () = check_denunciation_age vi denunciation_kind level.level in let* ctxt, consensus_key1 = Stake_distribution.slot_owner vi.ctxt level e1.slot @@ -1810,7 +1815,7 @@ module Anonymous = struct {hash1; level1; round1; hash2; level2; round2}) in let*? () = check_denunciation_age vi Block level1 in - let level = Level.from_raw vi.ctxt level1 in + let*? level = Level.from_raw vi.ctxt level1 in let committee_size = Constants.consensus_committee_size vi.ctxt in let*? slot1 = Round.to_slot round1 ~committee_size in let* ctxt, consensus_key1 = @@ -2034,7 +2039,7 @@ module Anonymous = struct {level = commitment_raw_level; nonce})) = operation.protocol_data.contents in - let commitment_level = Level.from_raw vi.ctxt commitment_raw_level in + let*? commitment_level = Level.from_raw vi.ctxt commitment_raw_level in let* () = Nonce.check_unrevealed vi.ctxt commitment_level nonce in return_unit diff --git a/src/proto_alpha/lib_protocol/vote_storage.ml b/src/proto_alpha/lib_protocol/vote_storage.ml index f2d110f8844b5..32f603b446bac 100644 --- a/src/proto_alpha/lib_protocol/vote_storage.ml +++ b/src/proto_alpha/lib_protocol/vote_storage.ml @@ -39,21 +39,21 @@ let get_proposals ctxt = Storage.Vote.Proposals.fold ctxt ~order:`Sorted - ~init:(ok Protocol_hash.Map.empty) + ~init:Protocol_hash.Map.empty ~f:(fun (proposal, delegate) acc -> (* Assuming the same listings is used at votings *) Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> Lwt.return - ( acc >|? fun acc -> - let previous = - match Protocol_hash.Map.find proposal acc with - | None -> 0L - | Some x -> x - in - Protocol_hash.Map.add proposal (Int64.add weight previous) acc )) + @@ ok + (let previous = + match Protocol_hash.Map.find proposal acc with + | None -> 0L + | Some x -> x + in + Protocol_hash.Map.add proposal (Int64.add weight previous) acc)) let clear_proposals ctxt = - Storage.Vote.Proposals_count.clear ctxt >>= fun ctxt -> + Storage.Vote.Proposals_count.clear ctxt >>=? fun ctxt -> Storage.Vote.Proposals.clear ctxt type ballots = {yay : int64; nay : int64; pass : int64} @@ -81,17 +81,17 @@ let get_ballots ctxt = Storage.Vote.Ballots.fold ctxt ~order:`Sorted - ~f:(fun delegate ballot (ballots : ballots tzresult) -> + ~f:(fun delegate ballot ballots -> (* Assuming the same listings is used at votings *) Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> let count = Int64.add weight in Lwt.return - ( ballots >|? fun ballots -> - match ballot with - | Yay -> {ballots with yay = count ballots.yay} - | Nay -> {ballots with nay = count ballots.nay} - | Pass -> {ballots with pass = count ballots.pass} )) - ~init:(ok ballots_zero) + @@ ok + (match ballot with + | Yay -> {ballots with yay = count ballots.yay} + | Nay -> {ballots with nay = count ballots.nay} + | Pass -> {ballots with pass = count ballots.pass})) + ~init:ballots_zero let get_ballot_list = Storage.Vote.Ballots.bindings @@ -105,7 +105,7 @@ let listings_encoding = (req "voting_power" int64))) let update_listings ctxt = - Storage.Vote.Listings.clear ctxt >>= fun ctxt -> + Storage.Vote.Listings.clear ctxt >>=? fun ctxt -> Stake_storage.fold ctxt (ctxt, 0L) @@ -191,7 +191,7 @@ let get_delegate_info ctxt delegate = | Proposal | Cooldown | Adoption -> return None) >>=? fun current_ballot -> (match period with - | Exploration | Promotion | Cooldown | Adoption -> Lwt.return [] + | Exploration | Promotion | Cooldown | Adoption -> Lwt.return @@ ok [] | Proposal -> Storage.Vote.Proposals.fold ctxt @@ -199,9 +199,9 @@ let get_delegate_info ctxt delegate = ~init:[] ~f:(fun (h, d) acc -> if Signature.Public_key_hash.equal d delegate then - Lwt.return (h :: acc) - else Lwt.return acc)) - >>= fun current_proposals -> + Lwt.return @@ ok (h :: acc) + else Lwt.return @@ ok acc)) + >>=? fun current_proposals -> let remaining_proposals = match period with | Proposal -> diff --git a/src/proto_alpha/lib_protocol/vote_storage.mli b/src/proto_alpha/lib_protocol/vote_storage.mli index 69d0619f781ab..4954ef086cac7 100644 --- a/src/proto_alpha/lib_protocol/vote_storage.mli +++ b/src/proto_alpha/lib_protocol/vote_storage.mli @@ -63,7 +63,7 @@ val add_proposal : (** Computes for each proposal how many delegates proposed it. *) val get_proposals : Raw_context.t -> int64 Protocol_hash.Map.t tzresult Lwt.t -val clear_proposals : Raw_context.t -> Raw_context.t Lwt.t +val clear_proposals : Raw_context.t -> Raw_context.t tzresult Lwt.t (** Counts of the votes *) type ballots = {yay : int64; nay : int64; pass : int64} @@ -95,9 +95,10 @@ val record_ballot : val get_ballots : Raw_context.t -> ballots tzresult Lwt.t val get_ballot_list : - Raw_context.t -> (Signature.Public_key_hash.t * Vote_repr.ballot) list Lwt.t + Raw_context.t -> + (Signature.Public_key_hash.t * Vote_repr.ballot) list tzresult Lwt.t -val clear_ballots : Raw_context.t -> Raw_context.t Lwt.t +val clear_ballots : Raw_context.t -> Raw_context.t tzresult Lwt.t val listings_encoding : (Signature.Public_key_hash.t * int64) list Data_encoding.t @@ -112,7 +113,7 @@ val update_listings : Raw_context.t -> Raw_context.t tzresult Lwt.t val in_listings : Raw_context.t -> Signature.Public_key_hash.t -> bool Lwt.t val get_listings : - Raw_context.t -> (Signature.Public_key_hash.t * int64) list Lwt.t + Raw_context.t -> (Signature.Public_key_hash.t * int64) list tzresult Lwt.t type delegate_info = { voting_power : Int64.t option; diff --git a/src/proto_alpha/lib_protocol/voting_services.ml b/src/proto_alpha/lib_protocol/voting_services.ml index b005d4d47a9c2..300f0bc2c4015 100644 --- a/src/proto_alpha/lib_protocol/voting_services.ml +++ b/src/proto_alpha/lib_protocol/voting_services.ml @@ -106,7 +106,7 @@ let register () = let open Services_registration in register0 ~chunked:false S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ; register0 ~chunked:true S.ballot_list (fun ctxt () () -> - Vote.get_ballot_list ctxt >|= ok) ; + Vote.get_ballot_list ctxt) ; register0 ~chunked:false S.current_period (fun ctxt () () -> Voting_period.get_rpc_current_info ctxt) ; register0 ~chunked:false S.successor_period (fun ctxt () () -> @@ -115,8 +115,7 @@ let register () = Vote.get_current_quorum ctxt) ; register0 ~chunked:true S.proposals (fun ctxt () () -> Vote.get_proposals ctxt) ; - register0 ~chunked:true S.listings (fun ctxt () () -> - Vote.get_listings ctxt >|= ok) ; + register0 ~chunked:true S.listings (fun ctxt () () -> Vote.get_listings ctxt) ; register0 ~chunked:false S.current_proposal (fun ctxt () () -> Vote.find_current_proposal ctxt) ; register0 ~chunked:false S.total_voting_power (fun ctxt () () -> diff --git a/src/proto_alpha/lib_protocol/zk_rollup_repr.ml b/src/proto_alpha/lib_protocol/zk_rollup_repr.ml index 52fe03aa9b9a0..451bd7dea3c7e 100644 --- a/src/proto_alpha/lib_protocol/zk_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/zk_rollup_repr.ml @@ -119,19 +119,20 @@ let pending_list_encoding : pending_list Data_encoding.t = module Index = struct type nonrec t = t - let path_length = 1 + let path_length : _ tzresult = ok 1 let to_path c l = let raw_key = Data_encoding.Binary.to_bytes_exn Address.encoding c in let (`Hex key) = Hex.of_bytes raw_key in key :: l - let of_path = function + let of_path : _ -> _ tzresult = function | [key] -> - Option.bind - (Hex.to_bytes (`Hex key)) - (Data_encoding.Binary.of_bytes_opt Address.encoding) - | _ -> None + ok + @@ Option.bind + (Hex.to_bytes (`Hex key)) + (Data_encoding.Binary.of_bytes_opt Address.encoding) + | _ -> ok None let rpc_arg = Address.rpc_arg -- GitLab