From a93eefc01839a7da7bf8c9b5272b7d1a106bed14 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 17 Feb 2022 23:22:16 +0100 Subject: [PATCH 01/63] SECTION 1: preparations. Removing some stuff, and factorizing others for future shared use. -- GitLab From 9c6931f0a7928ff4f218cd6c56e2cc3c3ecf4a54 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Tue, 15 Feb 2022 16:55:52 +0100 Subject: [PATCH 02/63] Proto/Michelson: remove operation_size. It is dead code, and it won't get in our way like this. --- .../lib_protocol/alpha_context.mli | 3 - .../lib_protocol/operation_repr.ml | 67 ------------------- .../lib_protocol/operation_repr.mli | 3 - .../lib_protocol/script_typed_ir_size.ml | 10 +-- 4 files changed, 3 insertions(+), 80 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 2931cde48ef4..2a1034d0db85 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2462,9 +2462,6 @@ module Operation : sig val internal_operation_encoding : packed_internal_operation Data_encoding.t - val packed_internal_operation_in_memory_size : - packed_internal_operation -> Cache_memory_helpers.nodes_and_size - val pack : 'kind operation -> packed_operation type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 98705d372423..c74f47937ba8 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -1257,70 +1257,3 @@ let equal : type a b. a operation -> b operation -> (a, b) eq option = equal_contents_kind_list op1.protocol_data.contents op2.protocol_data.contents - -open Cache_memory_helpers - -let script_lazy_expr_size (expr : Script_repr.lazy_expr) = - let fun_value expr = ret_adding (expr_size expr) word_size in - let fun_bytes bytes = (Nodes.zero, word_size +! bytes_size bytes) in - let fun_combine expr_size bytes_size = expr_size ++ bytes_size in - ret_adding - (Data_encoding.apply_lazy ~fun_value ~fun_bytes ~fun_combine expr) - header_size - -let script_repr_size ({code; storage} : Script_repr.t) = - ret_adding (script_lazy_expr_size code ++ script_lazy_expr_size storage) h2w - -let internal_manager_operation_size (type a) (op : a manager_operation) = - match op with - | Transaction {amount = _; parameters; entrypoint; destination} -> - ret_adding - (script_lazy_expr_size parameters) - (h4w +! int64_size - +! Entrypoint_repr.in_memory_size entrypoint - +! Destination_repr.in_memory_size destination) - | Origination {delegate; script; credit = _; preorigination} -> - ret_adding - (script_repr_size script) - (h4w - +! option_size - (fun _ -> Contract_repr.public_key_hash_in_memory_size) - delegate - +! int64_size - +! option_size Contract_repr.in_memory_size preorigination) - | Delegation pkh_opt -> - ( Nodes.zero, - h1w - +! option_size - (fun _ -> Contract_repr.public_key_hash_in_memory_size) - pkh_opt ) - | Sc_rollup_originate _ -> (Nodes.zero, h2w) - | Sc_rollup_add_messages _ -> (Nodes.zero, h2w) - | Reveal _ -> - (* Reveals can't occur as internal operations *) - assert false - | Register_global_constant _ -> - (* Global constant registrations can't occur as internal operations *) - assert false - | Set_deposits_limit _ -> - (* Set_deposits_limit can't occur as internal operations *) - assert false - | Tx_rollup_origination -> - (* Tx_rollup_origination operation can’t occur as internal operations *) - assert false - | Tx_rollup_submit_batch _ -> - (* Tx_rollup_submit_batch operation can’t occur as internal operations *) - assert false - | Tx_rollup_commit _ -> - (* Tx_rollup_commit operation can’t occur as internal operations *) - assert false - -let packed_internal_operation_in_memory_size : - packed_internal_operation -> nodes_and_size = function - | Internal_operation iop -> - let {source; operation; nonce = _} = iop in - let source_size = Contract_repr.in_memory_size source in - let nonce_size = word_size in - ret_adding - (internal_manager_operation_size operation) - (h2w +! source_size +! nonce_size) diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 506229d35065..0a2b6e2ce507 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -341,9 +341,6 @@ type ('a, 'b) eq = Eq : ('a, 'a) eq val equal : 'a operation -> 'b operation -> ('a, 'b) eq option -val packed_internal_operation_in_memory_size : - packed_internal_operation -> Cache_memory_helpers.nodes_and_size - module Encoding : sig type 'b case = | Case : { 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 4b83db408729..ff52caec2e7d 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -198,12 +198,6 @@ let sapling_state_size {Sapling.id; diff; memo_size = _} = +! Sapling.diff_in_memory_size diff +! sapling_memo_size_size -let operation_size {piop; lazy_storage_diff} = - ret_adding - (Operation.packed_internal_operation_in_memory_size piop - ++ option_size_vec Lazy_storage.diffs_in_memory_size lazy_storage_diff) - h2w - let chain_id_size = h1w +? Chain_id.size (* [contents] is handle by the recursion scheme in [value_size] *) @@ -313,7 +307,9 @@ let rec value_size : | Sapling_transaction_t _ -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x) - | Operation_t -> ret_succ (accu ++ operation_size x) + (* Operations are somewhat special values that can't be pushed on the stack + for instance. Requesting the size of an operation should not happen. *) + | Operation_t -> assert false | Chain_id_t -> ret_succ_adding accu chain_id_size | Never_t -> ( match x with _ -> .) (* Related to https://gitlab.com/dannywillems/ocaml-bls12-381/-/issues/56. -- GitLab From bb86a8a7a4a24c7c310a5fdbe2bf01c24a8f82aa Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Tue, 15 Feb 2022 23:11:39 +0100 Subject: [PATCH 03/63] Proto/Michelson: extract code_size and expose it. It will be used when creating a contract in order to make a typed script. --- .../lib_protocol/script_ir_translator.ml | 36 ++++++++++--------- .../lib_protocol/script_ir_translator.mli | 8 +++++ 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a2269dd33e46..59ce4aee36e0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5259,6 +5259,25 @@ let parse_contract_for_script : (ctxt, Some contract) | Error Inconsistent_types_fast -> (ctxt, None))) ))) +let code_size ctxt code views = + let open Script_typed_ir_size in + let view_size view = + node_size view.view_code ++ node_size view.input_ty + ++ node_size view.output_ty + in + let views_size = SMap.fold (fun _ v s -> view_size v ++ s) views zero in + (* The size of the storage_type and the arg_type is counted by + [lambda_size]. *) + let ir_size = lambda_size code in + let (nodes, code_size) = views_size ++ ir_size in + (* We consume gas after the fact in order to not have to instrument + [node_size] (for efficiency). + This is safe, as we already pay gas proportional to [views_size] and + [ir_size] during their typechecking. *) + Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes) + >>? fun ctxt -> + ok (ctxt, code_size) + let parse_code : ?type_logger:type_logger -> context -> @@ -5300,22 +5319,7 @@ let parse_code : code_field) >>=? fun (code, ctxt) -> Lwt.return - (let open Script_typed_ir_size in - let view_size view = - node_size view.view_code ++ node_size view.input_ty - ++ node_size view.output_ty - in - let views_size = SMap.fold (fun _ v s -> view_size v ++ s) views zero in - (* The size of the storage_type and the arg_type is counted by - [lambda_size]. *) - let ir_size = lambda_size code in - let (nodes, code_size) = views_size ++ ir_size in - (* We consume gas after the fact in order to not have to instrument - [node_size] (for efficiency). - This is safe, as we already pay gas proportional to [views_size] - and [ir_size] during their typechecking. *) - Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes) - >>? fun ctxt -> + (code_size ctxt code views >>? fun (ctxt, code_size) -> ok ( Ex_code {code; arg_type; storage_type; views; entrypoints; code_size}, ctxt )) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index c32b8b0e48b3..7d0c7583c8da 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -489,6 +489,14 @@ val get_single_sapling_state : 'a -> (Sapling.Id.t option * context) tzresult +(** [code_size ctxt code views] returns an overapproximation of the size of + the in-memory representation of [code] and [views] in the context [ctxt]. *) +val code_size : + context -> + ('a, 'b) Script_typed_ir.lambda -> + Script_typed_ir.view Script_typed_ir.SMap.t -> + (context * Cache_memory_helpers.sint) tzresult + (** [script_size script] returns an overapproximation of the size of the in-memory representation of [script] as well as the cost associated to computing that overapproximation. *) -- GitLab From d55c4db7caba38f04985a8b1161d55aacd23944d Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 3 Feb 2022 17:29:47 +0100 Subject: [PATCH 04/63] Proto/Michelson: extract internal operations' parameters. We will share them with a new type defined later. Internal operations are transaction, origination and tx_rollup_commit. Delegation is not extracted since it has a single parameter. --- .../lib_protocol/alpha_context.mli | 41 +++++++++++-------- .../lib_protocol/operation_repr.ml | 41 +++++++++++-------- .../lib_protocol/operation_repr.mli | 41 +++++++++++-------- 3 files changed, 69 insertions(+), 54 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 2a1034d0db85..e8981b149011 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2259,6 +2259,25 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit +type manager_transaction = { + amount : Tez.tez; + parameters : Script.lazy_expr; + entrypoint : Entrypoint.t; + destination : Destination.t; +} + +type manager_origination = { + delegate : Signature.Public_key_hash.t option; + script : Script.t; + credit : Tez.tez; + preorigination : Contract.t option; +} + +type manager_tx_rollup_commit = { + tx_rollup : Tx_rollup.t; + commitment : Tx_rollup_commitments.Commitment.t; +} + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -2329,20 +2348,8 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : { - amount : Tez.tez; - parameters : Script.lazy_expr; - entrypoint : Entrypoint.t; - destination : Destination.t; - } - -> Kind.transaction manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script.t; - credit : Tez.tez; - preorigination : Contract.t option; - } - -> Kind.origination manager_operation + | Transaction : manager_transaction -> Kind.transaction manager_operation + | Origination : manager_origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation @@ -2360,10 +2367,8 @@ and _ manager_operation = burn_limit : Tez.tez option; } -> Kind.tx_rollup_submit_batch manager_operation - | Tx_rollup_commit : { - tx_rollup : Tx_rollup.t; - commitment : Tx_rollup_commitments.Commitment.t; - } + | Tx_rollup_commit : + manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation | Sc_rollup_originate : { kind : Sc_rollup.Kind.t; diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index c74f47937ba8..72669db18b08 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -176,6 +176,25 @@ type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} let raw_encoding = Operation.encoding +type manager_transaction = { + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : Entrypoint_repr.t; + destination : Destination_repr.t; +} + +type manager_origination = { + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; + preorigination : Contract_repr.t option; +} + +type manager_tx_rollup_commit = { + tx_rollup : Tx_rollup_repr.t; + commitment : Tx_rollup_commitments_repr.Commitment.t; +} + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -246,20 +265,8 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : { - amount : Tez_repr.tez; - parameters : Script_repr.lazy_expr; - entrypoint : Entrypoint_repr.t; - destination : Destination_repr.t; - } - -> Kind.transaction manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script_repr.t; - credit : Tez_repr.tez; - preorigination : Contract_repr.t option; - } - -> Kind.origination manager_operation + | Transaction : manager_transaction -> Kind.transaction manager_operation + | Origination : manager_origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation @@ -277,10 +284,8 @@ and _ manager_operation = burn_limit : Tez_repr.t option; } -> Kind.tx_rollup_submit_batch manager_operation - | Tx_rollup_commit : { - tx_rollup : Tx_rollup_repr.t; - commitment : Tx_rollup_commitments_repr.Commitment.t; - } + | Tx_rollup_commit : + manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation | Sc_rollup_originate : { kind : Sc_rollup_repr.Kind.t; diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 0a2b6e2ce507..451d74867246 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -155,6 +155,25 @@ type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} val raw_encoding : raw Data_encoding.t +type manager_transaction = { + amount : Tez_repr.tez; + parameters : Script_repr.lazy_expr; + entrypoint : Entrypoint_repr.t; + destination : Destination_repr.t; +} + +type manager_origination = { + delegate : Signature.Public_key_hash.t option; + script : Script_repr.t; + credit : Tez_repr.tez; + preorigination : Contract_repr.t option; +} + +type manager_tx_rollup_commit = { + tx_rollup : Tx_rollup_repr.t; + commitment : Tx_rollup_commitments_repr.Commitment.t; +} + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -225,20 +244,8 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : { - amount : Tez_repr.tez; - parameters : Script_repr.lazy_expr; - entrypoint : Entrypoint_repr.t; - destination : Destination_repr.t; - } - -> Kind.transaction manager_operation - | Origination : { - delegate : Signature.Public_key_hash.t option; - script : Script_repr.t; - credit : Tez_repr.tez; - preorigination : Contract_repr.t option; - } - -> Kind.origination manager_operation + | Transaction : manager_transaction -> Kind.transaction manager_operation + | Origination : manager_origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation @@ -256,10 +263,8 @@ and _ manager_operation = burn_limit : Tez_repr.t option; } -> Kind.tx_rollup_submit_batch manager_operation - | Tx_rollup_commit : { - tx_rollup : Tx_rollup_repr.t; - commitment : Tx_rollup_commitments_repr.Commitment.t; - } + | Tx_rollup_commit : + manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation | Sc_rollup_originate : { kind : Sc_rollup_repr.Kind.t; -- GitLab From 4d18c1ccb1fb538988d8ae624016775a3ed60db2 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 13:40:29 +0100 Subject: [PATCH 05/63] Proto/Michelson: extract the delegation application. To share it between external and internal delegation. --- src/proto_alpha/lib_protocol/apply.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index a049c1ed410f..0c3ba54a0c42 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -831,6 +831,13 @@ let assert_tx_rollup_feature_enabled ctxt = let assert_sc_rollup_feature_enabled ctxt = fail_unless (Constants.sc_rollup_enable ctxt) Sc_rollup_feature_disabled +let apply_delegation ctxt source delegate since = + Delegate.set ctxt source delegate >|=? fun ctxt -> + ( ctxt, + Delegation_result + {consumed_gas = Gas.consumed ~since ~until:ctxt}, + [] ) + (** Retrieving the source code of a contract from its address is costly @@ -1103,11 +1110,7 @@ let apply_manager_operation_content : in (ctxt, result, []) | Delegation delegate -> - Delegate.set ctxt source delegate >|=? fun ctxt -> - ( ctxt, - Delegation_result - {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}, - [] ) + apply_delegation ctxt source delegate before_operation | Register_global_constant {value} -> (* Decode the value and consume gas appropriately *) Script.force_decode_in_context ~consume_deserialization_gas ctxt value -- GitLab From d9212c14f13cacfba0e428081f45df28b2719108 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 22:07:19 +0100 Subject: [PATCH 06/63] Proto/Michelson: make the transaction application a function. To extract it, abstract it a bit, and then share it between external and internal transaction. --- src/proto_alpha/lib_protocol/apply.ml | 30 ++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 0c3ba54a0c42..a84b04fce514 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -897,7 +897,21 @@ let apply_manager_operation_content : : kind successful_manager_operation_result), [] ) | Transaction - {amount; parameters; destination = Contract destination; entrypoint} -> ( + {amount; parameters; destination = Contract destination; entrypoint} -> + let apply_transaction + ~consume_deserialization_gas + ctxt + parameters + source + destination + amount + entrypoint + before_operation + payer + chain_id + mode + internal = + ( Script.force_decode_in_context ~consume_deserialization_gas ctxt @@ -1023,6 +1037,20 @@ let apply_manager_operation_content : }) in (ctxt, result, operations) )) + in + apply_transaction + ~consume_deserialization_gas + ctxt + parameters + source + destination + amount + entrypoint + before_operation + payer + chain_id + mode + internal | Origination {delegate; script; preorigination; credit} -> Script.force_decode_in_context ~consume_deserialization_gas -- GitLab From fec0b06c1efb94eb11b75d79f1ccf7bf7ad2137d Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 22:14:04 +0100 Subject: [PATCH 07/63] Proto/Michelson: extract the transaction application. --- src/proto_alpha/lib_protocol/apply.ml | 280 +++++++++++++------------- 1 file changed, 140 insertions(+), 140 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index a84b04fce514..1adf2cc9783c 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -838,6 +838,146 @@ let apply_delegation ctxt source delegate since = {consumed_gas = Gas.consumed ~since ~until:ctxt}, [] ) +let apply_transaction + ~consume_deserialization_gas + ctxt + parameters + source + destination + amount + entrypoint + before_operation + payer + chain_id + mode + internal = + Script.force_decode_in_context + ~consume_deserialization_gas + ctxt + parameters + >>?= fun (parameter, ctxt) -> + (match Contract.is_implicit destination with + | None -> + (if Tez.(amount = zero) then + (* Detect potential call to non existent contract. *) + Contract.must_exist ctxt destination + else return_unit) + >>=? fun () -> + (* Since the contract is originated, nothing will be allocated + or the next transfer of tokens will fail. *) + return_false + | Some _ -> + (* Transfers of zero to implicit accounts are forbidden. *) + error_when Tez.(amount = zero) (Empty_transaction destination) + >>?= fun () -> + (* If the implicit contract is not yet allocated at this point then + the next transfer of tokens will allocate it. *) + Contract.allocated ctxt destination >|=? not) + >>=? fun allocated_destination_contract -> + Token.transfer ctxt (`Contract source) (`Contract destination) amount + >>=? fun (ctxt, balance_updates) -> + Script_cache.find ctxt destination >>=? fun (ctxt, cache_key, script) -> + match script with + | None -> + Lwt.return + ( ( (if Entrypoint.is_default entrypoint then Result.return_unit + else error (Script_tc_errors.No_such_entrypoint entrypoint)) + >>? fun () -> + match Micheline.root parameter with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + ok ctxt + | _ -> + error + (Script_interpreter.Bad_contract_parameter destination) + ) + >|? fun ctxt -> + let result = + Transaction_result + (Transaction_to_contract_result + { + storage = None; + lazy_storage_diff = None; + balance_updates; + originated_contracts = []; + consumed_gas = + Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = Z.zero; + paid_storage_size_diff = Z.zero; + allocated_destination_contract; + }) + in + (ctxt, result, []) ) + | Some (script, script_ir) -> + (* Token.transfer which is being called above already loads this + value into the Irmin cache, so no need to burn gas for it. *) + Contract.get_balance ctxt destination >>=? fun balance -> + let now = Script_timestamp.now ctxt in + let level = + (Level.current ctxt).level |> Raw_level.to_int32 |> Script_int.of_int32 + |> Script_int.abs + in + let step_constants = + let open Script_interpreter in + { + source; + payer; + self = destination; + amount; + chain_id; + balance; + now; + level; + } + in + Script_interpreter.execute + ctxt + ~cached_script:(Some script_ir) + mode + step_constants + ~script + ~parameter + ~entrypoint + ~internal + >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, + (updated_cached_script, updated_size) ) -> + Contract.update_script_storage + ctxt + destination + storage + lazy_storage_diff + >>=? fun ctxt -> + Fees.record_paid_storage_space ctxt destination + >>=? fun (ctxt, new_size, paid_storage_size_diff) -> + Contract.originated_from_current_nonce + ~since:before_operation + ~until:ctxt + >>=? fun originated_contracts -> + Lwt.return + ( Script_cache.update + ctxt + cache_key + ( {script with storage = Script.lazy_expr storage}, + updated_cached_script ) + updated_size + >|? fun ctxt -> + let result = + Transaction_result + (Transaction_to_contract_result + { + storage = Some storage; + lazy_storage_diff; + balance_updates; + originated_contracts; + consumed_gas = + Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = new_size; + paid_storage_size_diff; + allocated_destination_contract; + }) + in + (ctxt, result, operations) ) + (** Retrieving the source code of a contract from its address is costly @@ -898,146 +1038,6 @@ let apply_manager_operation_content : [] ) | Transaction {amount; parameters; destination = Contract destination; entrypoint} -> - let apply_transaction - ~consume_deserialization_gas - ctxt - parameters - source - destination - amount - entrypoint - before_operation - payer - chain_id - mode - internal = - ( - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - parameters - >>?= fun (parameter, ctxt) -> - (match Contract.is_implicit destination with - | None -> - (if Tez.(amount = zero) then - (* Detect potential call to non existent contract. *) - Contract.must_exist ctxt destination - else return_unit) - >>=? fun () -> - (* Since the contract is originated, nothing will be allocated - or the next transfer of tokens will fail. *) - return_false - | Some _ -> - (* Transfers of zero to implicit accounts are forbidden. *) - error_when Tez.(amount = zero) (Empty_transaction destination) - >>?= fun () -> - (* If the implicit contract is not yet allocated at this point then - the next transfer of tokens will allocate it. *) - Contract.allocated ctxt destination >|=? not) - >>=? fun allocated_destination_contract -> - Token.transfer ctxt (`Contract source) (`Contract destination) amount - >>=? fun (ctxt, balance_updates) -> - Script_cache.find ctxt destination >>=? fun (ctxt, cache_key, script) -> - match script with - | None -> - Lwt.return - ( ( (if Entrypoint.is_default entrypoint then Result.return_unit - else error (Script_tc_errors.No_such_entrypoint entrypoint)) - >>? fun () -> - match Micheline.root parameter with - | Prim (_, D_Unit, [], _) -> - (* Allow [Unit] parameter to non-scripted contracts. *) - ok ctxt - | _ -> - error - (Script_interpreter.Bad_contract_parameter destination) ) - >|? fun ctxt -> - let result = - Transaction_result - (Transaction_to_contract_result - { - storage = None; - lazy_storage_diff = None; - balance_updates; - originated_contracts = []; - consumed_gas = - Gas.consumed ~since:before_operation ~until:ctxt; - storage_size = Z.zero; - paid_storage_size_diff = Z.zero; - allocated_destination_contract; - }) - in - (ctxt, result, []) ) - | Some (script, script_ir) -> - (* Token.transfer which is being called above already loads this - value into the Irmin cache, so no need to burn gas for it. *) - Contract.get_balance ctxt destination >>=? fun balance -> - let now = Script_timestamp.now ctxt in - let level = - (Level.current ctxt).level |> Raw_level.to_int32 - |> Script_int.of_int32 |> Script_int.abs - in - let step_constants = - let open Script_interpreter in - { - source; - payer; - self = destination; - amount; - chain_id; - balance; - now; - level; - } - in - Script_interpreter.execute - ctxt - ~cached_script:(Some script_ir) - mode - step_constants - ~script - ~parameter - ~entrypoint - ~internal - >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, - (updated_cached_script, updated_size) ) -> - Contract.update_script_storage - ctxt - destination - storage - lazy_storage_diff - >>=? fun ctxt -> - Fees.record_paid_storage_space ctxt destination - >>=? fun (ctxt, new_size, paid_storage_size_diff) -> - Contract.originated_from_current_nonce - ~since:before_operation - ~until:ctxt - >>=? fun originated_contracts -> - Lwt.return - ( Script_cache.update - ctxt - cache_key - ( {script with storage = Script.lazy_expr storage}, - updated_cached_script ) - updated_size - >|? fun ctxt -> - let result = - Transaction_result - (Transaction_to_contract_result - { - storage = Some storage; - lazy_storage_diff; - balance_updates; - originated_contracts; - consumed_gas = - Gas.consumed ~since:before_operation ~until:ctxt; - storage_size = new_size; - paid_storage_size_diff; - allocated_destination_contract; - }) - in - (ctxt, result, operations) )) - in apply_transaction ~consume_deserialization_gas ctxt -- GitLab From f060f23f75b3a0ef429a59c8acfd5845fd058328 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Tue, 15 Feb 2022 16:09:21 +0100 Subject: [PATCH 08/63] Proto/Michelson: make the origination application a function. To extract it, abstract it a bit, and then share it between external and internal origination. --- src/proto_alpha/lib_protocol/apply.ml | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 1adf2cc9783c..961b8c165d0e 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1052,6 +1052,16 @@ let apply_manager_operation_content : mode internal | Origination {delegate; script; preorigination; credit} -> + let apply_origination + consume_deserialization_gas + ctxt + (script : Script.t) + internal + preorigination + delegate + source + credit + before_operation = Script.force_decode_in_context ~consume_deserialization_gas ctxt @@ -1137,6 +1147,17 @@ let apply_manager_operation_content : } in (ctxt, result, []) + in + apply_origination + consume_deserialization_gas + ctxt + script + internal + preorigination + delegate + source + credit + before_operation | Delegation delegate -> apply_delegation ctxt source delegate before_operation | Register_global_constant {value} -> -- GitLab From 376b38af546c4056e04b0c46b25b7e982338f3c9 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 5 Feb 2022 11:45:28 +0100 Subject: [PATCH 09/63] Proto/Michelson: extract the origination application. --- src/proto_alpha/lib_protocol/apply.ml | 192 +++++++++++++------------- 1 file changed, 96 insertions(+), 96 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 961b8c165d0e..dfd382be811a 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -978,6 +978,102 @@ let apply_transaction in (ctxt, result, operations) ) +let apply_origination + consume_deserialization_gas + ctxt + script + internal + preorigination + delegate + source + credit + before_operation = + Script.force_decode_in_context + ~consume_deserialization_gas + ctxt + script.Script.storage + >>?= fun (_unparsed_storage, ctxt) -> + Script.force_decode_in_context + ~consume_deserialization_gas + ctxt + script.Script.code + >>?= fun (unparsed_code, ctxt) -> + Script_ir_translator.parse_script + ctxt + ~legacy:false + ~allow_forged_in_storage:internal + script + >>=? fun (Ex_script parsed_script, ctxt) -> + let views_result = + Script_ir_translator.typecheck_views + ctxt + ~legacy:false + parsed_script.storage_type + parsed_script.views + in + trace + (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) + views_result + >>=? fun ctxt -> + Script_ir_translator.collect_lazy_storage + ctxt + parsed_script.storage_type + parsed_script.storage + >>?= fun (to_duplicate, ctxt) -> + let to_update = Script_ir_translator.no_lazy_storage_id in + Script_ir_translator.extract_lazy_storage_diff + ctxt + Optimized + parsed_script.storage_type + parsed_script.storage + ~to_duplicate + ~to_update + ~temporary:false + >>=? fun (storage, lazy_storage_diff, ctxt) -> + Script_ir_translator.unparse_data + ctxt + Optimized + parsed_script.storage_type + storage + >>=? fun (storage, ctxt) -> + let storage = Script.lazy_expr (Micheline.strip_locations storage) in + let script = {script with storage} in + (match preorigination with + | Some contract -> + assert internal ; + (* The preorigination field is only used to early return + the address of an originated contract in Michelson. + It cannot come from the outside. *) + ok (ctxt, contract) + | None -> Contract.fresh_contract_from_current_nonce ctxt) + >>?= fun (ctxt, contract) -> + Contract.raw_originate + ctxt + ~prepaid_bootstrap_storage:false + contract + ~script:(script, lazy_storage_diff) + >>=? fun ctxt -> + (match delegate with + | None -> return ctxt + | Some delegate -> Delegate.init ctxt contract delegate) + >>=? fun ctxt -> + Token.transfer ctxt (`Contract source) (`Contract contract) credit + >>=? fun (ctxt, balance_updates) -> + Fees.record_paid_storage_space ctxt contract + >|=? fun (ctxt, size, paid_storage_size_diff) -> + let result = + Origination_result + { + lazy_storage_diff; + balance_updates; + originated_contracts = [contract]; + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + storage_size = size; + paid_storage_size_diff; + } + in + (ctxt, result, []) + (** Retrieving the source code of a contract from its address is costly @@ -1052,102 +1148,6 @@ let apply_manager_operation_content : mode internal | Origination {delegate; script; preorigination; credit} -> - let apply_origination - consume_deserialization_gas - ctxt - (script : Script.t) - internal - preorigination - delegate - source - credit - before_operation = - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.storage - >>?= fun (_unparsed_storage, ctxt) -> - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - script.code - >>?= fun (unparsed_code, ctxt) -> - Script_ir_translator.parse_script - ctxt - ~legacy:false - ~allow_forged_in_storage:internal - script - >>=? fun (Ex_script parsed_script, ctxt) -> - let views_result = - Script_ir_translator.typecheck_views - ctxt - ~legacy:false - parsed_script.storage_type - parsed_script.views - in - trace - (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) - views_result - >>=? fun ctxt -> - Script_ir_translator.collect_lazy_storage - ctxt - parsed_script.storage_type - parsed_script.storage - >>?= fun (to_duplicate, ctxt) -> - let to_update = Script_ir_translator.no_lazy_storage_id in - Script_ir_translator.extract_lazy_storage_diff - ctxt - Optimized - parsed_script.storage_type - parsed_script.storage - ~to_duplicate - ~to_update - ~temporary:false - >>=? fun (storage, lazy_storage_diff, ctxt) -> - Script_ir_translator.unparse_data - ctxt - Optimized - parsed_script.storage_type - storage - >>=? fun (storage, ctxt) -> - let storage = Script.lazy_expr (Micheline.strip_locations storage) in - let script = {script with storage} in - (match preorigination with - | Some contract -> - assert internal ; - (* The preorigination field is only used to early return - the address of an originated contract in Michelson. - It cannot come from the outside. *) - ok (ctxt, contract) - | None -> Contract.fresh_contract_from_current_nonce ctxt) - >>?= fun (ctxt, contract) -> - Contract.raw_originate - ctxt - ~prepaid_bootstrap_storage:false - contract - ~script:(script, lazy_storage_diff) - >>=? fun ctxt -> - (match delegate with - | None -> return ctxt - | Some delegate -> Delegate.init ctxt contract delegate) - >>=? fun ctxt -> - Token.transfer ctxt (`Contract source) (`Contract contract) credit - >>=? fun (ctxt, balance_updates) -> - Fees.record_paid_storage_space ctxt contract - >|=? fun (ctxt, size, paid_storage_size_diff) -> - let result = - Origination_result - { - lazy_storage_diff; - balance_updates; - originated_contracts = [contract]; - consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; - storage_size = size; - paid_storage_size_diff; - } - in - (ctxt, result, []) - in apply_origination consume_deserialization_gas ctxt -- GitLab From 7d62b146af88d2d3d41d91ace01bc6e22cf289a4 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 18 Feb 2022 17:16:22 +0100 Subject: [PATCH 10/63] Proto/Michelson: make the tx_rollup_commit application a function. To extract it and share it between external and internal transaction. --- src/proto_alpha/lib_protocol/apply.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index dfd382be811a..c62fca143d4c 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1253,7 +1253,8 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_commit {tx_rollup; commitment} -> ( + | Tx_rollup_commit {tx_rollup; commitment} -> + let apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation = (* TODO: bonds https://gitlab.com/tezos/tezos/-/issues/2459 *) match Contract.is_implicit source with | None -> @@ -1269,7 +1270,9 @@ let apply_manager_operation_content : balance_updates = []; } in - return (ctxt, result, [])) + return (ctxt, result, []) + in + apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation | Sc_rollup_originate {kind; boot_sector} -> Sc_rollup_operations.originate ctxt ~kind ~boot_sector >>=? fun ({address; size}, ctxt) -> -- GitLab From d4d9149726403fbf0c7769341976d10b1ceddf9e Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 18 Feb 2022 17:18:52 +0100 Subject: [PATCH 11/63] Proto/Michelson: extract the tx_rollup_commit application. --- src/proto_alpha/lib_protocol/apply.ml | 36 +++++++++++++-------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index c62fca143d4c..56ed083d0fbd 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1074,6 +1074,24 @@ let apply_origination in (ctxt, result, []) +let apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation = + (* TODO: bonds https://gitlab.com/tezos/tezos/-/issues/2459 *) + match Contract.is_implicit source with + | None -> + fail Tx_rollup_commit_with_non_implicit_contract + (* This is only called with implicit contracts *) + | Some key -> + Tx_rollup_commitments.add_commitment ctxt tx_rollup key commitment + >>=? fun ctxt -> + let result = + Tx_rollup_commit_result + { + consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; + balance_updates = []; + } + in + return (ctxt, result, []) + (** Retrieving the source code of a contract from its address is costly @@ -1254,24 +1272,6 @@ let apply_manager_operation_content : in return (ctxt, result, []) | Tx_rollup_commit {tx_rollup; commitment} -> - let apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation = - (* TODO: bonds https://gitlab.com/tezos/tezos/-/issues/2459 *) - match Contract.is_implicit source with - | None -> - fail Tx_rollup_commit_with_non_implicit_contract - (* This is only called with implicit contracts *) - | Some key -> - Tx_rollup_commitments.add_commitment ctxt tx_rollup key commitment - >>=? fun ctxt -> - let result = - Tx_rollup_commit_result - { - consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; - balance_updates = []; - } - in - return (ctxt, result, []) - in apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation | Sc_rollup_originate {kind; boot_sector} -> Sc_rollup_operations.originate ctxt ~kind ~boot_sector -- GitLab From 286c0f65f01c7f5a515d3083b1d410b55a6c7304 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 17 Feb 2022 23:29:13 +0100 Subject: [PATCH 12/63] SECTION 2: define and use the new type for internal operations. We make it simple for now: just a copy of the previous structures, but restricted to actual the internal operations (transactions, originations and delegations), not just *any* operation as was the case before. -- GitLab From eaca8095c4f69f0452b7a4c27826d561b54bf783 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 3 Feb 2022 23:04:28 +0100 Subject: [PATCH 13/63] Proto/Michelson: define a new type for internal operations. Script_typed_ir.internal_operation will now be the type for operations generated by smart contracts. It is pretty much a restriction of the previous internal operation type (Alpha_context.internal_operation). We will remove the latter later. Script_typed_ir.operation is made mutually recursive with ty right now, because some internal operations fields will carry a ty. Does not compile. --- .../lib_protocol/script_typed_ir.ml | 33 ++++++++++++++++--- .../lib_protocol/script_typed_ir.mli | 33 ++++++++++++++++--- 2 files changed, 56 insertions(+), 10 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index a595f3f764a0..a215d9aff25a 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -98,11 +98,6 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b -type operation = { - piop : packed_internal_operation; - lazy_storage_diff : Lazy_storage.diffs option; -} - module Script_chain_id = struct type t = Chain_id_tag of Chain_id.t [@@ocaml.unboxed] @@ -1406,6 +1401,34 @@ and ('a, 'b) view_signature = output_ty : 'b ty; } +and operation = { + piop : packed_internal_operation; + lazy_storage_diff : Lazy_storage.diffs option; +} + +and packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +and 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +and 'kind manager_operation = + | Transaction : + Alpha_context.manager_transaction + -> Kind.transaction manager_operation + | Origination : + Alpha_context.manager_origination + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit manager_operation + let kinfo_of_kinstr : type a s b f. (a, s, b, f) kinstr -> (a, s) kinfo = fun i -> match i with diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 75fa5e457ddc..48ba29ca96c2 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -78,11 +78,6 @@ type ('a, 'b) pair = 'a * 'b type ('a, 'b) union = L of 'a | R of 'b -type operation = { - piop : packed_internal_operation; - lazy_storage_diff : Lazy_storage.diffs option; -} - module Script_chain_id : sig (** [t] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) @@ -1533,6 +1528,34 @@ and ('a, 'b) view_signature = output_ty : 'b ty; } +and operation = { + piop : packed_internal_operation; + lazy_storage_diff : Lazy_storage.diffs option; +} + +and packed_internal_operation = + | Internal_operation : 'kind internal_operation -> packed_internal_operation + +and 'kind internal_operation = { + source : Contract.contract; + operation : 'kind manager_operation; + nonce : int; +} + +and 'kind manager_operation = + | Transaction : + Alpha_context.manager_transaction + -> Kind.transaction manager_operation + | Origination : + Alpha_context.manager_origination + -> Kind.origination manager_operation + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation manager_operation + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit manager_operation + val kinfo_of_kinstr : ('a, 's, 'b, 'f) kinstr -> ('a, 's) kinfo type kinstr_rewritek = { -- GitLab From 373e544e2d8da6dd915b62615a18a95aeef1a120 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Tue, 15 Feb 2022 17:17:31 +0100 Subject: [PATCH 14/63] Proto/Michelson: introduce a few temporary helper functions. They are used to go back to untyped internal operations and ease the production of receipts in Apply_results. But they will be removed once the new internal operations are plugged in Apply_results. Does not compile. --- .../lib_protocol/script_typed_ir.ml | 20 +++++++++++++++++++ .../lib_protocol/script_typed_ir.mli | 15 ++++++++++++++ 2 files changed, 35 insertions(+) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index a215d9aff25a..e83ff167454f 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1429,6 +1429,26 @@ and 'kind manager_operation = Alpha_context.manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation +let unty_internal_operation : + type kind. kind internal_operation -> kind Alpha_context.internal_operation + = + fun {source; operation; nonce} -> + let operation : kind Alpha_context.manager_operation = + match operation with + | Transaction transaction -> Alpha_context.Transaction transaction + | Origination origination -> Alpha_context.Origination origination + | Delegation delegate -> Alpha_context.Delegation delegate + | Tx_rollup_commit tx_rollup_commit -> + Alpha_context.Tx_rollup_commit tx_rollup_commit + in + Alpha_context.{source; operation; nonce} + +let unty_packed_internal_operation (Internal_operation operation) = + let operation = unty_internal_operation operation in + Alpha_context.Internal_operation operation + +let unty_operations = List.map unty_packed_internal_operation + let kinfo_of_kinstr : type a s b f. (a, s, b, f) kinstr -> (a, s) kinfo = fun i -> match i with diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 48ba29ca96c2..6d75d4a3bc06 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1556,6 +1556,21 @@ and 'kind manager_operation = Alpha_context.manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation +(** [unty_internal_operation iop] removes the typing information inside + [iop]. *) +val unty_internal_operation : + 'kind internal_operation -> 'kind Alpha_context.internal_operation + +(** [unty_packed_internal_operation piop] removes the typing information inside + [piop]. *) +val unty_packed_internal_operation : + packed_internal_operation -> Alpha_context.packed_internal_operation + +(** [unty_operations ops] removes the typing information inside each operation + of [ops]. *) +val unty_operations : + packed_internal_operation list -> Alpha_context.packed_internal_operation list + val kinfo_of_kinstr : ('a, 's, 'b, 'f) kinstr -> ('a, 's) kinfo type kinstr_rewritek = { -- GitLab From 3c0131010e5f2095a8742c061b9e9b018873df60 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 10:17:15 +0100 Subject: [PATCH 15/63] Proto/Michelson: applying an operation returns an internal operation. The ones from Script_typed_ir.packed_internal_operation. It's pretty much handled by Apply.apply_manager_operation_content that now accepts an internal *or* external operation as input (with the new any_manager_operation type), and returns internal operations. Does not compile. --- src/proto_alpha/lib_protocol/apply.ml | 80 ++++++++++++++----- .../lib_protocol/script_ir_translator.ml | 1 + 2 files changed, 59 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 56ed083d0fbd..7be6338bfb0c 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1092,6 +1092,10 @@ let apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation = in return (ctxt, result, []) +type 'kind any_manager_operation = + | Internal_mop of 'kind Script_typed_ir.manager_operation + | External_mop of 'kind Alpha_context.manager_operation + (** Retrieving the source code of a contract from its address is costly @@ -1113,10 +1117,10 @@ let apply_manager_operation_content : chain_id:Chain_id.t -> internal:bool -> gas_consumed_in_precheck:Gas.cost option -> - kind manager_operation -> + kind any_manager_operation -> (context * kind successful_manager_operation_result - * packed_internal_operation list) + * Script_typed_ir.packed_internal_operation list) tzresult Lwt.t = fun ctxt @@ -1142,7 +1146,7 @@ let apply_manager_operation_content : (* [note]: deserialization gas has already been accounted for in the gas consumed by the precheck and the lazy_exprs have been forced. *) match operation with - | Reveal _ -> + | External_mop (Reveal _) -> return (* No-op: action already performed by `precheck_manager_contents`. *) ( ctxt, @@ -1150,8 +1154,8 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} : kind successful_manager_operation_result), [] ) - | Transaction - {amount; parameters; destination = Contract destination; entrypoint} -> + | External_mop (Transaction + {amount; parameters; destination = Contract destination; entrypoint}) -> apply_transaction ~consume_deserialization_gas ctxt @@ -1165,7 +1169,22 @@ let apply_manager_operation_content : chain_id mode internal - | Origination {delegate; script; preorigination; credit} -> + | Internal_mop (Transaction + {amount; parameters; destination = Contract destination; entrypoint}) -> + apply_transaction + ~consume_deserialization_gas + ctxt + parameters + source + destination + amount + entrypoint + before_operation + payer + chain_id + mode + internal + | External_mop (Origination {delegate; script; preorigination; credit}) -> apply_origination consume_deserialization_gas ctxt @@ -1176,9 +1195,22 @@ let apply_manager_operation_content : source credit before_operation - | Delegation delegate -> + | Internal_mop (Origination {delegate; script; preorigination; credit}) -> + apply_origination + consume_deserialization_gas + ctxt + script + internal + preorigination + delegate + source + credit + before_operation + | External_mop (Delegation delegate) -> apply_delegation ctxt source delegate before_operation - | Register_global_constant {value} -> + | Internal_mop (Delegation delegate) -> + apply_delegation ctxt source delegate before_operation + | External_mop (Register_global_constant {value}) -> (* Decode the value and consume gas appropriately *) Script.force_decode_in_context ~consume_deserialization_gas ctxt value >>?= fun (expr, ctxt) -> @@ -1210,7 +1242,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Set_deposits_limit limit -> ( + | External_mop (Set_deposits_limit limit) -> ( (match limit with | None -> Result.return_unit | Some limit -> @@ -1242,7 +1274,7 @@ let apply_manager_operation_content : consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt; }, [] )) - | Tx_rollup_origination -> + | External_mop Tx_rollup_origination -> Tx_rollup.originate ctxt >>=? fun (ctxt, originated_tx_rollup) -> let result = Tx_rollup_origination_result @@ -1253,7 +1285,7 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> + | External_mop (Tx_rollup_submit_batch {tx_rollup; content; burn_limit}) -> assert_tx_rollup_feature_enabled ctxt >>=? fun () -> let (message, message_size) = Tx_rollup_message.make_batch content in Tx_rollup_state.get ctxt tx_rollup >>=? fun (ctxt, state) -> @@ -1271,9 +1303,11 @@ let apply_manager_operation_content : } in return (ctxt, result, []) - | Tx_rollup_commit {tx_rollup; commitment} -> + | External_mop (Tx_rollup_commit {tx_rollup; commitment}) -> + apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation + | Internal_mop (Tx_rollup_commit {tx_rollup; commitment}) -> apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation - | Sc_rollup_originate {kind; boot_sector} -> + | External_mop (Sc_rollup_originate {kind; boot_sector}) -> Sc_rollup_operations.originate ctxt ~kind ~boot_sector >>=? fun ({address; size}, ctxt) -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in @@ -1282,7 +1316,7 @@ let apply_manager_operation_content : {address; consumed_gas; size; balance_updates = []} in return (ctxt, result, []) - | Sc_rollup_add_messages {rollup; messages} -> + | External_mop (Sc_rollup_add_messages {rollup; messages}) -> Sc_rollup.add_messages ctxt rollup messages >>=? fun (inbox_after, _size, ctxt) -> let consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt in @@ -1295,9 +1329,10 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = let[@coq_struct "ctxt"] rec apply ctxt applied worklist = match worklist with | [] -> Lwt.return (Success ctxt, List.rev applied) - | Internal_operation ({source; operation; nonce} as op) :: rest -> ( + | Script_typed_ir.Internal_operation ({source; operation; nonce} as op) :: rest -> ( + let op_for_result = Script_typed_ir.unty_internal_operation op in (if internal_nonce_already_recorded ctxt nonce then - fail (Internal_operation_replay (Internal_operation op)) + fail (Internal_operation_replay (Internal_operation op_for_result)) else let ctxt = record_internal_nonce ctxt nonce in apply_manager_operation_content @@ -1308,25 +1343,26 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = ~chain_id ~internal:true ~gas_consumed_in_precheck:None - operation) + (Internal_mop operation)) >>= function | Error errors -> let result = Internal_operation_result - (op, Failed (manager_kind op.operation, errors)) + (op_for_result, Failed (manager_kind op_for_result.operation, errors)) in let skipped = List.rev_map - (fun (Internal_operation op) -> + (fun (Script_typed_ir.Internal_operation op) -> + let op_for_result = Script_typed_ir.unty_internal_operation op in Internal_operation_result - (op, Skipped (manager_kind op.operation))) + (op_for_result, Skipped (manager_kind op_for_result.operation))) rest in Lwt.return (Failure, List.rev (skipped @ result :: applied)) | Ok (ctxt, result, emitted) -> apply ctxt - (Internal_operation_result (op, Applied result) :: applied) + (Internal_operation_result (op_for_result, Applied result) :: applied) (emitted @ rest)) in apply ctxt [] ops @@ -1581,7 +1617,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ~internal:false ~gas_consumed_in_precheck ~chain_id - operation + (External_mop operation) >>= function | Ok (ctxt, operation_results, internal_operations) -> ( apply_internal_manager_operations diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 59ce4aee36e0..416fda7f05bb 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -480,6 +480,7 @@ let unparse_key_hash ~loc ctxt mode k = (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = + let piop = unty_packed_internal_operation piop in let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding piop in -- GitLab From f4a6fe1089119cdbcb8057ad3dc951c9e48792c1 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 10:25:21 +0100 Subject: [PATCH 16/63] Proto/Plugin: remove typing information from operations. Does not compile. --- src/proto_alpha/lib_plugin/plugin.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index a404b33372bf..c6bb32695b37 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2245,7 +2245,7 @@ module RPC = struct lazy_storage_diff; _; }, - _ ) -> (storage, operations, lazy_storage_diff)) ; + _ ) -> (storage, Script_typed_ir.unty_operations operations, lazy_storage_diff)) ; Registration.register0 ~chunked:true S.trace_code @@ -2311,7 +2311,7 @@ module RPC = struct lazy_storage_diff; _; }, - trace ) -> (storage, operations, trace, lazy_storage_diff)) ; + trace ) -> (storage, Script_typed_ir.unty_operations operations, trace, lazy_storage_diff)) ; Registration.register0 ~chunked:true S.run_view @@ -2400,7 +2400,7 @@ module RPC = struct >>=? fun ({Script_interpreter.operations; _}, (_, _)) -> View_helpers.extract_parameter_from_operations entrypoint - operations + (Script_typed_ir.unty_operations operations) viewer_contract >>?= fun parameter -> Lwt.return (Script_repr.force_decode parameter)) ; Registration.register0 -- GitLab From 651a06eb9febd6b8bfebf5217e18d248fec2c5a4 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 11:44:51 +0100 Subject: [PATCH 17/63] Proto/Benchmark: generate internal operation. --- src/proto_alpha/lib_benchmark/michelson_samplers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index 9c2157543f2c..74f1cbdc2e21 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -693,7 +693,7 @@ end) Script_typed_ir.{piop = transfer; lazy_storage_diff = None} and generate_transfer_tokens : - Alpha_context.packed_internal_operation sampler = + Script_typed_ir.packed_internal_operation sampler = fun _rng_state -> fail_sampling "generate_transfer_tokens: unimplemented" and generate_bls12_381_g1 : Script_bls.G1.t sampler = -- GitLab From a6da5a8e9c7617ec39cab1db8860014125236536 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 17 Feb 2022 23:49:49 +0100 Subject: [PATCH 18/63] SECTION 3: enrich the transaction internal operation. We add a typed version of the parameters, so that we won't need to reparse them. The interpreter (Script_interpreter.execute) needs to accept this typed version of the parameters. -- GitLab From 68a6911fbb1a0da556df8c56bb18882c8fd4912a Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 14:29:59 +0100 Subject: [PATCH 19/63] Proto/Michelson: enrich execute's [parameter] parameter 1/3. So that the function accepts both a typed or an untyped version of the parameter. This will allow not having to re-parse the parameter if it was already parsed. Does not compile. --- src/proto_alpha/lib_protocol/apply.ml | 4 ++-- .../lib_protocol/script_interpreter.ml | 20 ++++++++++++++++++- .../lib_protocol/script_interpreter.mli | 6 +++++- .../test/helpers/contract_helpers.ml | 2 +- 4 files changed, 27 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 7be6338bfb0c..c82094a715f1 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -936,7 +936,7 @@ let apply_transaction mode step_constants ~script - ~parameter + ~parameter:(Untyped_arg parameter) ~entrypoint ~internal >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, @@ -2630,7 +2630,7 @@ let apply_liquidity_baking_subsidy ctxt ~escape_vote = Optimized step_constants ~script - ~parameter + ~parameter:(Untyped_arg parameter) ~cached_script:(Some script_ir) ~entrypoint:Entrypoint.default ~internal:false diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index f6831ed5e160..11771c6d0fe0 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1671,6 +1671,10 @@ let internal_step ctxt step_constants gas kinstr accu stack = let step logger ctxt step_constants descr stack = step_descr ~log_now:false logger (ctxt, step_constants) descr stack +type execution_arg = + | Typed_arg : 'a Script_typed_ir.ty * 'a -> execution_arg + | Untyped_arg : Script.expr -> execution_arg + (* High-level functions @@ -1712,9 +1716,23 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal >>?= fun (r, ctxt) -> record_trace (Bad_contract_parameter step_constants.self) r >>?= fun (box, _) -> + (match arg with + | Untyped_arg arg -> + let arg = Micheline.root arg in trace (Bad_contract_parameter step_constants.self) (parse_data ctxt ~legacy:false ~allow_forged:internal arg_type (box arg)) + | Typed_arg (_parsed_arg_ty, _parsed_arg) -> + (* TODO (MR comment): there is some set-up to fill this branch. *) + + (* 1. Check that [parsed_arg_ty] from the argument is equal to + [entrypoint_ty] (the type expected by the entrypoint), so that we can + convert [parsed_arg] (of type [parsed_arg_ty]) to [entrypoint_ty]. *) + + (* 2. Rebuild the whole argument structure (like [box] in the untyped + case). *) + + assert false) >>=? fun (arg, ctxt) -> Script_ir_translator.collect_lazy_storage ctxt arg_type arg >>?= fun (to_duplicate, ctxt) -> @@ -1787,7 +1805,7 @@ let execute ?logger ctxt ~cached_script mode step_constants ~script ~entrypoint ~internal script cached_script - (Micheline.root parameter) + parameter >|=? fun (storage, operations, ctxt, lazy_storage_diff, ex_script, approx_size) -> ({ctxt; storage; lazy_storage_diff; operations}, (ex_script, approx_size)) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index 7b003e1f42cc..9d96c8c5fb00 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -77,6 +77,10 @@ val step : 's -> ('r * 'f * context) tzresult Lwt.t +type execution_arg = + | Typed_arg : 'a Script_typed_ir.ty * 'a -> execution_arg + | Untyped_arg : Script.expr -> execution_arg + (** [execute ?logger ctxt ~cached_script mode step_constant ~script ~entrypoint ~parameter ~internal] interprets the [script]'s [entrypoint] for a given [parameter]. @@ -106,7 +110,7 @@ val execute : step_constants -> script:Script.t -> entrypoint:Entrypoint.t -> - parameter:Script.expr -> + parameter:execution_arg -> internal:bool -> (execution_result * (Script_ir_translator.ex_script * int)) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml index 2570b95a18e5..8fa0c2592ab1 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml @@ -97,6 +97,6 @@ let run_script ctx ?(step_constants = default_step_constants) contract ~script ~cached_script:None ~entrypoint - ~parameter:parameter_expr + ~parameter:(Untyped_arg parameter_expr) ~internal:false >>=?? fun res -> return res -- GitLab From ef065d76d698d1bed92e66a0babaa2e30c84be4f Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 15:06:39 +0100 Subject: [PATCH 20/63] Proto/Plugin: enrich execute's [parameter] parameter. --- src/proto_alpha/lib_plugin/plugin.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index c6bb32695b37..01a607854453 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2237,7 +2237,7 @@ module RPC = struct ~cached_script:None ~script:{storage; code} ~entrypoint - ~parameter + ~parameter:(Untyped_arg parameter) ~internal:true >|=? fun ( { Script_interpreter.storage; @@ -2304,7 +2304,7 @@ module RPC = struct step_constants ~script:{storage; code} ~entrypoint - ~parameter + ~parameter:(Untyped_arg parameter) >|=? fun ( { Script_interpreter.storage; operations; @@ -2395,7 +2395,7 @@ module RPC = struct ~script ~cached_script:None ~entrypoint - ~parameter + ~parameter:(Untyped_arg parameter) ~internal:true >>=? fun ({Script_interpreter.operations; _}, (_, _)) -> View_helpers.extract_parameter_from_operations -- GitLab From 9b2b9d40af339f743bcc326cd27a11358b5b80cf Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 17:27:03 +0100 Subject: [PATCH 21/63] Proto/Michelson: enrich execute's [parameter] parameter 2/3. Confront the parameter's type with the expected type from the script. --- .../lib_protocol/script_interpreter.ml | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 11771c6d0fe0..6e6f2a232e65 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1715,19 +1715,24 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) >>?= fun (r, ctxt) -> record_trace (Bad_contract_parameter step_constants.self) r - >>?= fun (box, _) -> + >>?= fun (box, Ex_ty entrypoint_ty) -> (match arg with | Untyped_arg arg -> let arg = Micheline.root arg in trace (Bad_contract_parameter step_constants.self) (parse_data ctxt ~legacy:false ~allow_forged:internal arg_type (box arg)) - | Typed_arg (_parsed_arg_ty, _parsed_arg) -> + | Typed_arg (parsed_arg_ty, _parsed_arg) -> (* TODO (MR comment): there is some set-up to fill this branch. *) - - (* 1. Check that [parsed_arg_ty] from the argument is equal to - [entrypoint_ty] (the type expected by the entrypoint), so that we can - convert [parsed_arg] (of type [parsed_arg_ty]) to [entrypoint_ty]. *) + Gas_monad.run + ctxt + (Script_ir_translator.ty_eq + ~error_details:Informative + Micheline.dummy_location + entrypoint_ty + parsed_arg_ty) + >>?= fun (res, _ctxt) -> + res >>?= fun Eq -> (* 2. Rebuild the whole argument structure (like [box] in the untyped case). *) -- GitLab From 686511596b8b90c71ce25e3a0bd009cdb994bcf0 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 15:58:28 +0100 Subject: [PATCH 22/63] Proto/Michelson: find_entrypoint returns the typed reconstructor. Does not compile. --- .../lib_protocol/script_ir_translator.ml | 16 +++++++++------- .../lib_protocol/script_ir_translator.mli | 8 +++++++- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 416fda7f05bb..e10ba1dfae41 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1826,10 +1826,12 @@ type 'before dup_n_proof_argument = ('before, 'a) dup_n_gadt_witness * 'a ty -> 'before dup_n_proof_argument +type 'a ex_ty_cstr = Ex_ty_cstr : 'b ty * ('b -> 'a) -> 'a ex_ty_cstr + let find_entrypoint (type full error_trace) ~(error_details : error_trace error_details) (full : full ty) (entrypoints : full entrypoints) entrypoint : - ((Script.node -> Script.node) * ex_ty, error_trace) Gas_monad.t = + ((Script.node -> Script.node) * full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in let loc = Micheline.dummy_location in let rec find_entrypoint : @@ -1837,25 +1839,25 @@ let find_entrypoint (type full error_trace) t ty -> t entrypoints -> Entrypoint.t -> - ((Script.node -> Script.node) * ex_ty, unit) Gas_monad.t = + ((Script.node -> Script.node) * 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 | (_, {name = Some name; _}) when Entrypoint.(name = entrypoint) -> - return ((fun e -> e), Ex_ty ty) + return ((fun e -> e), Ex_ty_cstr (ty, fun e -> e)) | (Union_t (tl, tr, _), {nested = Entrypoints_Union {left; right}; _}) -> ( Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function - | Ok (f, t) -> return ((fun e -> Prim (loc, D_Left, [f e], [])), t) + | Ok (f, Ex_ty_cstr (t, f')) -> return ((fun e -> Prim (loc, D_Left, [f e], [])), Ex_ty_cstr (t, fun e -> L (f' e))) | Error () -> - let+ (f, t) = find_entrypoint tr right entrypoint in - ((fun e -> Prim (loc, D_Right, [f e], [])), t)) + let+ (f, Ex_ty_cstr (t, f')) = find_entrypoint tr right entrypoint in + ((fun e -> Prim (loc, D_Right, [f e], [])), Ex_ty_cstr (t, fun e -> R (f' e)))) | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in Gas_monad.bind_recover (find_entrypoint full entrypoints entrypoint) @@ function | Ok f_t -> return f_t | Error () -> - if Entrypoint.is_default entrypoint then return ((fun e -> e), Ex_ty full) + if Entrypoint.is_default entrypoint then return ((fun e -> e), Ex_ty_cstr (full, fun e -> e)) else Gas_monad.of_result @@ Error diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 7d0c7583c8da..9567c076b457 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -411,12 +411,18 @@ val parse_contract_for_script : entrypoint:Entrypoint.t -> (context * 'a Script_typed_ir.typed_contract option) tzresult Lwt.t +(** ['a ex_ty_cstr] is like [ex_ty], but also adds to the existential a function + used to reconstruct a value of type ['a] from the internal type of the + existential (typically, that will be the type of en antry-point). *) +type 'a ex_ty_cstr = + | Ex_ty_cstr : 'b Script_typed_ir.ty * ('b -> 'a) -> 'a ex_ty_cstr + val find_entrypoint : error_details:'error_trace error_details -> 't Script_typed_ir.ty -> 't Script_typed_ir.entrypoints -> Entrypoint.t -> - ((Script.node -> Script.node) * ex_ty, 'error_trace) Gas_monad.t + ((Script.node -> Script.node) * 't ex_ty_cstr, 'error_trace) Gas_monad.t val list_entrypoints : context -> -- GitLab From c8798a2ad5b4cbc6b6a24a42f5f38ef03d2a1d28 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 16:09:59 +0100 Subject: [PATCH 23/63] Proto/Michelson: define find_entrypoint_cstr instead of find_entrypoint. By redefining the later using the former, so that there are no impacts on other modules. --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 9 ++++++++- src/proto_alpha/lib_protocol/script_ir_translator.mli | 9 ++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index e10ba1dfae41..81fc91217352 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1828,7 +1828,7 @@ type 'before dup_n_proof_argument = type 'a ex_ty_cstr = Ex_ty_cstr : 'b ty * ('b -> 'a) -> 'a ex_ty_cstr -let find_entrypoint (type full error_trace) +let find_entrypoint_cstr (type full error_trace) ~(error_details : error_trace error_details) (full : full ty) (entrypoints : full entrypoints) entrypoint : ((Script.node -> Script.node) * full ex_ty_cstr, error_trace) Gas_monad.t = @@ -1865,6 +1865,13 @@ let find_entrypoint (type full error_trace) | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) +let find_entrypoint ~error_details full entrypoints entrypoint = + let open Gas_monad.Syntax in + let+ (f, Ex_ty_cstr (t, _)) = + find_entrypoint_cstr ~error_details full entrypoints entrypoint + in + (f, Ex_ty t) + let find_entrypoint_for_type (type full exp error_trace) ~error_details ~(full : full ty) ~(expected : exp ty) entrypoints entrypoint loc : (Entrypoint.t * exp ty, error_trace) Gas_monad.t = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 9567c076b457..d0bc076e648f 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -417,13 +417,20 @@ val parse_contract_for_script : type 'a ex_ty_cstr = | Ex_ty_cstr : 'b Script_typed_ir.ty * ('b -> 'a) -> 'a ex_ty_cstr -val find_entrypoint : +val find_entrypoint_cstr : error_details:'error_trace error_details -> 't Script_typed_ir.ty -> 't Script_typed_ir.entrypoints -> Entrypoint.t -> ((Script.node -> Script.node) * 't ex_ty_cstr, 'error_trace) Gas_monad.t +val find_entrypoint : + error_details:'error_trace error_details -> + 't Script_typed_ir.ty -> + 't Script_typed_ir.entrypoints -> + Entrypoint.t -> + ((Script.node -> Script.node) * ex_ty, 'error_trace) Gas_monad.t + val list_entrypoints : context -> 't Script_typed_ir.ty -> -- GitLab From d02facc5689cbb8d6702f37e62a1407d93cf7aaa Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 16:34:06 +0100 Subject: [PATCH 24/63] Proto/Michelson: enrich execute's [parameter] parameter 3/3. Rebuild the parameter structure depending on the entry-point. --- src/proto_alpha/lib_protocol/script_interpreter.ml | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 6e6f2a232e65..19569e432811 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1712,18 +1712,17 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal ctxt ) -> Gas_monad.run ctxt - (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) + (find_entrypoint_cstr ~error_details:Informative arg_type entrypoints entrypoint) >>?= fun (r, ctxt) -> record_trace (Bad_contract_parameter step_constants.self) r - >>?= fun (box, Ex_ty entrypoint_ty) -> + >>?= fun (box, Ex_ty_cstr (entrypoint_ty, typed_box)) -> (match arg with | Untyped_arg arg -> let arg = Micheline.root arg in trace (Bad_contract_parameter step_constants.self) (parse_data ctxt ~legacy:false ~allow_forged:internal arg_type (box arg)) - | Typed_arg (parsed_arg_ty, _parsed_arg) -> - (* TODO (MR comment): there is some set-up to fill this branch. *) + | Typed_arg (parsed_arg_ty, parsed_arg) -> Gas_monad.run ctxt (Script_ir_translator.ty_eq @@ -1731,13 +1730,10 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal Micheline.dummy_location entrypoint_ty parsed_arg_ty) - >>?= fun (res, _ctxt) -> + >>?= fun (res, ctxt) -> res >>?= fun Eq -> - (* 2. Rebuild the whole argument structure (like [box] in the untyped - case). *) - - assert false) + return (typed_box parsed_arg, ctxt)) >>=? fun (arg, ctxt) -> Script_ir_translator.collect_lazy_storage ctxt arg_type arg >>?= fun (to_duplicate, ctxt) -> -- GitLab From 9f8115b7fe7fb78cb62235f53a96f70162916fb1 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 22:51:03 +0100 Subject: [PATCH 25/63] Proto/Michelson: enrich the transaction application with a typed parameter. --- src/proto_alpha/lib_protocol/apply.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index c82094a715f1..bbf101bbecf2 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -841,6 +841,7 @@ let apply_delegation ctxt source delegate since = let apply_transaction ~consume_deserialization_gas ctxt + typed_parameters parameters source destination @@ -930,13 +931,16 @@ let apply_transaction level; } in + let parameter = match typed_parameters with + | None -> Script_interpreter.Untyped_arg parameter + | Some (arg_ty, arg) -> Script_interpreter.Typed_arg (arg_ty, arg) in Script_interpreter.execute ctxt ~cached_script:(Some script_ir) mode step_constants ~script - ~parameter:(Untyped_arg parameter) + ~parameter ~entrypoint ~internal >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, @@ -1159,6 +1163,7 @@ let apply_manager_operation_content : apply_transaction ~consume_deserialization_gas ctxt + None parameters source destination @@ -1174,6 +1179,7 @@ let apply_manager_operation_content : apply_transaction ~consume_deserialization_gas ctxt + None parameters source destination -- GitLab From 1066da8c994006894a2ef61e5a7bf821efc68f09 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 4 Feb 2022 23:14:03 +0100 Subject: [PATCH 26/63] Proto/Michelson: enrich the transaction internal operation. With the typed parameter of the transaction. --- src/proto_alpha/lib_protocol/apply.ml | 10 +++++++--- .../lib_protocol/script_interpreter_defs.ml | 8 ++++++-- src/proto_alpha/lib_protocol/script_typed_ir.ml | 10 +++++++--- src/proto_alpha/lib_protocol/script_typed_ir.mli | 7 +++++-- 4 files changed, 25 insertions(+), 10 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index bbf101bbecf2..a539b7cc03d6 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1174,12 +1174,16 @@ let apply_manager_operation_content : chain_id mode internal - | Internal_mop (Transaction - {amount; parameters; destination = Contract destination; entrypoint}) -> + | Internal_mop + (Transaction + {manager_transaction; parameters_ty; parameters = typed_parameters}) -> + let {amount; parameters; destination = Contract destination; entrypoint} = + manager_transaction + in apply_transaction ~consume_deserialization_gas ctxt - None + (Some (parameters_ty, typed_parameters)) parameters source destination diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index d6b0b1a3d2d4..9459dcbfccd7 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -511,10 +511,11 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = ~to_update ~temporary:true >>=? fun (p, lazy_storage_diff, ctxt) -> + let parameters_ty = tp in + let parameters = p in unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost p) >>?= fun ctxt -> - let operation = - Transaction + let manager_transaction = { amount; destination; @@ -522,6 +523,9 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = parameters = Script.lazy_expr (Micheline.strip_locations p); } in + let operation = + Transaction {manager_transaction; parameters_ty; parameters} + in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let iop = {source = sc.self; operation; nonce} in let res = {piop = Internal_operation iop; lazy_storage_diff} in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index e83ff167454f..640c1f20a543 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1416,8 +1416,11 @@ and 'kind internal_operation = { } and 'kind manager_operation = - | Transaction : - Alpha_context.manager_transaction + | Transaction : { + manager_transaction : Alpha_context.manager_transaction; + parameters_ty : 'arg ty; + parameters : 'arg; + } -> Kind.transaction manager_operation | Origination : Alpha_context.manager_origination @@ -1435,7 +1438,8 @@ let unty_internal_operation : fun {source; operation; nonce} -> let operation : kind Alpha_context.manager_operation = match operation with - | Transaction transaction -> Alpha_context.Transaction transaction + | Transaction {manager_transaction; parameters_ty = _; parameters = _} -> + Alpha_context.Transaction manager_transaction | Origination origination -> Alpha_context.Origination origination | Delegation delegate -> Alpha_context.Delegation delegate | Tx_rollup_commit tx_rollup_commit -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 6d75d4a3bc06..352afd37e0d0 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1543,8 +1543,11 @@ and 'kind internal_operation = { } and 'kind manager_operation = - | Transaction : - Alpha_context.manager_transaction + | Transaction : { + manager_transaction : Alpha_context.manager_transaction; + parameters_ty : 'arg ty; + parameters : 'arg; + } -> Kind.transaction manager_operation | Origination : Alpha_context.manager_origination -- GitLab From bbc1f2e576cfd4e64ae855aa503c09e328e6c29d Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 17 Feb 2022 23:52:29 +0100 Subject: [PATCH 27/63] SECTION 4.1: enrich the origination internal operation. We add a typed version of the script, which allows not to reparse it when returning the origination operation and executing it. -- GitLab From 3abff81ba6a98ae1787d5c8cbcc10ffed6e8b465 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Tue, 15 Feb 2022 23:33:25 +0100 Subject: [PATCH 28/63] Proto/Michelson: enrich the origination application with a parsed script. --- src/proto_alpha/lib_protocol/apply.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index a539b7cc03d6..582397457daa 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -985,6 +985,7 @@ let apply_transaction let apply_origination consume_deserialization_gas ctxt + parsed_script script internal preorigination @@ -1002,11 +1003,14 @@ let apply_origination ctxt script.Script.code >>?= fun (unparsed_code, ctxt) -> + (match parsed_script with + | None -> Script_ir_translator.parse_script ctxt ~legacy:false ~allow_forged_in_storage:internal script + | Some parsed_script -> return (Script_ir_translator.Ex_script parsed_script, ctxt)) >>=? fun (Ex_script parsed_script, ctxt) -> let views_result = Script_ir_translator.typecheck_views @@ -1198,6 +1202,7 @@ let apply_manager_operation_content : apply_origination consume_deserialization_gas ctxt + None script internal preorigination @@ -1209,6 +1214,7 @@ let apply_manager_operation_content : apply_origination consume_deserialization_gas ctxt + None script internal preorigination -- GitLab From 36fc6ed9a04044cd348231bad6f938884083fa7f Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Wed, 16 Feb 2022 09:47:55 +0100 Subject: [PATCH 29/63] Proto/Michelson: enrich create_contract with a lambda. That will be used to create a typed script. --- src/proto_alpha/lib_protocol/script_interpreter.ml | 3 ++- src/proto_alpha/lib_protocol/script_interpreter_defs.ml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 19569e432811..4033709fbd53 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1127,7 +1127,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = { storage_type; arg_type; - lambda = Lam (_, code); + lambda = Lam (_, code) as lambda; views; entrypoints; k; @@ -1141,6 +1141,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = gas storage_type arg_type + lambda code views entrypoints diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 9459dcbfccd7..b4129061310e 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -541,7 +541,7 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = (* TODO: https://gitlab.com/tezos/tezos/-/issues/1688 Refactor the sharing part of unparse_script and create_contract *) -let create_contract (ctxt, sc) gas storage_type param_type code views +let create_contract (ctxt, sc) gas storage_type param_type _lambda code views entrypoints delegate credit init = let ctxt = update_context gas ctxt in let loc = Micheline.dummy_location in -- GitLab From 20c8e55fa3abfe020957c8fbb769a31e3b9e751c Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 7 Feb 2022 13:51:54 +0100 Subject: [PATCH 30/63] Proto/Michelson: enrich the origination internal operation. The fields are already available when creating a contract, and this allows other modules, like ticket_operations_diff, to use it without parsing it yet again. --- src/proto_alpha/lib_protocol/apply.ml | 4 ++-- .../lib_protocol/script_interpreter_defs.ml | 22 ++++++++++++++----- .../lib_protocol/script_typed_ir.ml | 9 +++++--- .../lib_protocol/script_typed_ir.mli | 6 +++-- 4 files changed, 29 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 582397457daa..46c9985ec320 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1210,11 +1210,11 @@ let apply_manager_operation_content : source credit before_operation - | Internal_mop (Origination {delegate; script; preorigination; credit}) -> + | Internal_mop (Origination {manager_origination = {delegate; script; preorigination; credit}; parsed_script}) -> apply_origination consume_deserialization_gas ctxt - None + (Some parsed_script) script internal preorigination diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index b4129061310e..bdf344739b24 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -541,7 +541,7 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = (* TODO: https://gitlab.com/tezos/tezos/-/issues/1688 Refactor the sharing part of unparse_script and create_contract *) -let create_contract (ctxt, sc) gas storage_type param_type _lambda code views +let create_contract (ctxt, sc) gas storage_type param_type lambda code views entrypoints delegate credit init = let ctxt = update_context gas ctxt in let loc = Micheline.dummy_location in @@ -562,7 +562,7 @@ let create_contract (ctxt, sc) gas storage_type param_type _lambda code views [] ) :: views in - let views = SMap.fold view views [] |> List.rev in + let view_list = SMap.fold view views [] |> List.rev in let code = strip_locations (Seq @@ -572,7 +572,7 @@ let create_contract (ctxt, sc) gas storage_type param_type _lambda code views Prim (loc, K_storage, [unparsed_storage_type], []); Prim (loc, K_code, [code], []); ] - @ views )) + @ view_list )) in collect_lazy_storage ctxt storage_type init >>?= fun (to_duplicate, ctxt) -> let to_update = no_lazy_storage_id in @@ -589,8 +589,7 @@ let create_contract (ctxt, sc) gas storage_type param_type _lambda code views Gas.consume ctxt (Script.strip_locations_cost storage) >>?= fun ctxt -> let storage = strip_locations storage in Contract.fresh_contract_from_current_nonce ctxt >>?= fun (ctxt, contract) -> - let operation = - Origination + let manager_origination = { credit; delegate; @@ -599,6 +598,19 @@ let create_contract (ctxt, sc) gas storage_type param_type _lambda code views {code = Script.lazy_expr code; storage = Script.lazy_expr storage}; } in + Script_ir_translator.code_size ctxt lambda views >>?= fun (ctxt, code_size) -> + let parsed_script = + { + code = lambda; + arg_type = param_type; + storage = init; + storage_type; + views; + entrypoints; + code_size; + } + in + let operation = Origination {manager_origination; parsed_script} in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in let res = {piop; lazy_storage_diff} in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 640c1f20a543..553caac3afae 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1422,8 +1422,10 @@ and 'kind manager_operation = parameters : 'arg; } -> Kind.transaction manager_operation - | Origination : - Alpha_context.manager_origination + | Origination : { + manager_origination : Alpha_context.manager_origination; + parsed_script : ('arg, 'storage) script; + } -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option @@ -1440,7 +1442,8 @@ let unty_internal_operation : match operation with | Transaction {manager_transaction; parameters_ty = _; parameters = _} -> Alpha_context.Transaction manager_transaction - | Origination origination -> Alpha_context.Origination origination + | Origination {manager_origination; parsed_script = _} -> + Alpha_context.Origination manager_origination | Delegation delegate -> Alpha_context.Delegation delegate | Tx_rollup_commit tx_rollup_commit -> Alpha_context.Tx_rollup_commit tx_rollup_commit diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 352afd37e0d0..9c6ac6afe781 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1549,8 +1549,10 @@ and 'kind manager_operation = parameters : 'arg; } -> Kind.transaction manager_operation - | Origination : - Alpha_context.manager_origination + | Origination : { + manager_origination : Alpha_context.manager_origination; + parsed_script : ('arg, 'storage) script; + } -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -- GitLab From 580259d3ef7340c4fc873eefafa62df232d2797f Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 18 Feb 2022 08:48:05 +0100 Subject: [PATCH 31/63] SECTION 4.2: move preorigination to internal origination only. -- GitLab From 4f40a7915af0c5dd6f517ce4bd4607b7ee6e9e67 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 5 Feb 2022 23:22:17 +0100 Subject: [PATCH 32/63] Proto/Michelson: move preorigination to internal origination only. Because this is what's happening: preorigination is filled when the origination is internal, not when it is requested by a user. Does not compile. --- .../lib_protocol/alpha_context.mli | 1 - src/proto_alpha/lib_protocol/apply.ml | 24 ++++++++----------- .../lib_protocol/operation_repr.ml | 8 +------ .../lib_protocol/operation_repr.mli | 1 - .../lib_protocol/script_interpreter_defs.ml | 5 ++-- .../lib_protocol/script_typed_ir.ml | 3 ++- .../lib_protocol/script_typed_ir.mli | 1 + .../lib_protocol/test/helpers/op.ml | 4 ++-- .../lib_protocol/test/helpers/op.mli | 1 - .../lib_protocol/ticket_operations_diff.ml | 4 ++-- 10 files changed, 21 insertions(+), 31 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index e8981b149011..e7195b900fc3 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2270,7 +2270,6 @@ type manager_origination = { delegate : Signature.Public_key_hash.t option; script : Script.t; credit : Tez.tez; - preorigination : Contract.t option; } type manager_tx_rollup_commit = { diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 46c9985ec320..26a817868015 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -988,7 +988,7 @@ let apply_origination parsed_script script internal - preorigination + preoriginate delegate source credit @@ -1046,15 +1046,7 @@ let apply_origination >>=? fun (storage, ctxt) -> let storage = Script.lazy_expr (Micheline.strip_locations storage) in let script = {script with storage} in - (match preorigination with - | Some contract -> - assert internal ; - (* The preorigination field is only used to early return - the address of an originated contract in Michelson. - It cannot come from the outside. *) - ok (ctxt, contract) - | None -> Contract.fresh_contract_from_current_nonce ctxt) - >>?= fun (ctxt, contract) -> + preoriginate ctxt >>?= fun (ctxt, contract) -> Contract.raw_originate ctxt ~prepaid_bootstrap_storage:false @@ -1198,26 +1190,30 @@ let apply_manager_operation_content : chain_id mode internal - | External_mop (Origination {delegate; script; preorigination; credit}) -> + | External_mop (Origination {delegate; script; credit}) -> + (* The preoriginate parameter is only used to early return the address of + an originated contract in Michelson. It cannot come from the + outside. *) + let preoriginate ctxt = Contract.fresh_contract_from_current_nonce ctxt in apply_origination consume_deserialization_gas ctxt None script internal - preorigination + preoriginate delegate source credit before_operation - | Internal_mop (Origination {manager_origination = {delegate; script; preorigination; credit}; parsed_script}) -> + | Internal_mop (Origination {manager_origination = {delegate; script; credit}; preorigination; parsed_script}) -> apply_origination consume_deserialization_gas ctxt (Some parsed_script) script internal - preorigination + (fun ctxt -> ok (ctxt, preorigination)) delegate source credit diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 72669db18b08..fbacac217dbc 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -187,7 +187,6 @@ type manager_origination = { delegate : Signature.Public_key_hash.t option; script : Script_repr.t; credit : Tez_repr.tez; - preorigination : Contract_repr.t option; } type manager_tx_rollup_commit = { @@ -477,16 +476,11 @@ module Encoding = struct credit; delegate; script; - preorigination = - _ - (* the hash is only used internally - when originating from smart - contracts, don't serialize it *); } -> (credit, delegate, script)); inj = (fun (credit, delegate, script) -> - Origination {credit; delegate; script; preorigination = None}); + Origination {credit; delegate; script}); } let[@coq_axiom_with_reason "gadt"] delegation_case = diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 451d74867246..91ce0a4a4f3d 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -166,7 +166,6 @@ type manager_origination = { delegate : Signature.Public_key_hash.t option; script : Script_repr.t; credit : Tez_repr.tez; - preorigination : Contract_repr.t option; } type manager_tx_rollup_commit = { diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index bdf344739b24..672f6320bf49 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -593,7 +593,6 @@ let create_contract (ctxt, sc) gas storage_type param_type lambda code views { credit; delegate; - preorigination = Some contract; script = {code = Script.lazy_expr code; storage = Script.lazy_expr storage}; } @@ -610,7 +609,9 @@ let create_contract (ctxt, sc) gas storage_type param_type lambda code views code_size; } in - let operation = Origination {manager_origination; parsed_script} in + let operation = + Origination {manager_origination; preorigination = contract; parsed_script} + in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in let res = {piop; lazy_storage_diff} in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 553caac3afae..0e76f2ef70ce 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1424,6 +1424,7 @@ and 'kind manager_operation = -> Kind.transaction manager_operation | Origination : { manager_origination : Alpha_context.manager_origination; + preorigination : Contract.t; parsed_script : ('arg, 'storage) script; } -> Kind.origination manager_operation @@ -1442,7 +1443,7 @@ let unty_internal_operation : match operation with | Transaction {manager_transaction; parameters_ty = _; parameters = _} -> Alpha_context.Transaction manager_transaction - | Origination {manager_origination; parsed_script = _} -> + | Origination {manager_origination; preorigination = _; parsed_script = _} -> Alpha_context.Origination manager_origination | Delegation delegate -> Alpha_context.Delegation delegate | Tx_rollup_commit tx_rollup_commit -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 9c6ac6afe781..42a36993102e 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1551,6 +1551,7 @@ and 'kind manager_operation = -> Kind.transaction manager_operation | Origination : { manager_origination : Alpha_context.manager_origination; + preorigination : Contract.t; parsed_script : ('arg, 'storage) script; } -> Kind.origination manager_operation diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index f9cee94d50f2..ca1b539fdab0 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -310,7 +310,7 @@ let originated_contract op = exception Impossible -let contract_origination ?counter ?delegate ~script ?(preorigination = None) +let contract_origination ?counter ?delegate ~script ?public_key ?credit ?fee ?gas_limit ?storage_limit ctxt source = Context.Contract.manager ctxt source >>=? fun account -> let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in @@ -318,7 +318,7 @@ let contract_origination ?counter ?delegate ~script ?(preorigination = None) WithExceptions.Option.to_exn ~none:Impossible default_credit in let credit = Option.value ~default:default_credit credit in - let operation = Origination {delegate; script; credit; preorigination} in + let operation = Origination {delegate; script; credit} in manager_operation ?counter ?public_key diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index f2781898e3bf..ccf86e2b973b 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -99,7 +99,6 @@ val contract_origination : ?counter:Z.t -> ?delegate:public_key_hash -> script:Script.t -> - ?preorigination:Contract.contract option -> ?public_key:public_key -> ?credit:Tez.tez -> ?fee:Tez.tez -> diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 555951a41882..f6140f7a0d16 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -243,8 +243,8 @@ let tickets_of_operation ctxt destination = Destination.Contract destination; } -> tickets_of_transaction ctxt ~destination ~parameters - | Origination {delegate = _; script; credit = _; preorigination} -> - tickets_of_origination ctxt ~preorigination script + | Origination {delegate = _; script; credit = _} -> + tickets_of_origination ctxt ~preorigination:None script | Delegation _ -> return (None, ctxt) | Register_global_constant _ -> return (None, ctxt) | Set_deposits_limit _ -> return (None, ctxt) -- GitLab From 66a0d3d460a2d9871d2169baa337a28c0b331cc0 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 5 Feb 2022 23:25:12 +0100 Subject: [PATCH 33/63] Proto/Plugin: preorigination is not for external originations anymore. Does not compile. --- src/proto_alpha/lib_plugin/plugin.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 01a607854453..c3303dd852c3 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -3042,7 +3042,6 @@ module RPC = struct delegate = delegatePubKey; script; credit = balance; - preorigination = None; }); ] -- GitLab From 23367d1f299ea9759114455e8101b72301f55828 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 5 Feb 2022 23:31:48 +0100 Subject: [PATCH 34/63] Proto/Client: preorigination is not for external originations anymore. --- src/proto_alpha/lib_client/client_proto_context.ml | 1 - src/proto_alpha/lib_client/operation_result.ml | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 80b187271ac5..093d3c41d76a 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -362,7 +362,6 @@ let build_origination_operation ?fee ?gas_limit ?storage_limit ~initial_storage delegate; script = {code; storage}; credit = balance; - preorigination = None; } in return diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 503c81d1c170..a9297e1e785d 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -58,7 +58,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf expr) ; pp_result ppf result ; Format.fprintf ppf "@]" - | Origination {delegate; credit; script = {code; storage}; preorigination = _} + | Origination {delegate; credit; script = {code; storage}} -> Format.fprintf ppf -- GitLab From fba1706554c429b405ea84230c02724acf8d1b38 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 18 Feb 2022 08:55:52 +0100 Subject: [PATCH 35/63] SECTION 5: adapt ticket modules and their tests. -- GitLab From 61b54579c94adef370a55d4ca850a0078d47051a Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 18 Feb 2022 23:12:31 +0100 Subject: [PATCH 36/63] Proto/Michelson: use internal operations in ticket_accouting. Does not compile. --- src/proto_alpha/lib_protocol/ticket_accounting.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.mli b/src/proto_alpha/lib_protocol/ticket_accounting.mli index fb91eae764f5..946595056479 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.mli +++ b/src/proto_alpha/lib_protocol/ticket_accounting.mli @@ -59,5 +59,5 @@ val update_ticket_balances : Alpha_context.context -> self:Alpha_context.Contract.t -> ticket_diffs:Z.t Ticket_token_map.t -> - Alpha_context.packed_internal_operation list -> + Script_typed_ir.packed_internal_operation list -> (Z.t * Alpha_context.t) tzresult Lwt.t -- GitLab From 4f49635867c58d728526ab273219b152e5890b6c Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 7 Feb 2022 14:30:19 +0100 Subject: [PATCH 37/63] Proto/Michelson: use internal operations in ticket_operations_diff. --- .../lib_protocol/ticket_operations_diff.ml | 104 +++--------------- .../lib_protocol/ticket_operations_diff.mli | 2 +- 2 files changed, 15 insertions(+), 91 deletions(-) diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index f6140f7a0d16..5f0fa21b68c5 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -130,101 +130,31 @@ module Ticket_token_map = struct map end -let parse_and_cache_script ctxt ~destination ~get_non_cached_script = - Script_cache.find ctxt destination >>=? fun (ctxt, _cache_key, cached) -> - match cached with - | Some (_script, ex_script) -> return (ex_script, ctxt) - | None -> - get_non_cached_script ctxt >>=? fun (script, ctxt) -> - Script_ir_translator.parse_script - ctxt - ~legacy:true - ~allow_forged_in_storage:true - script - >>=? fun (ex_script, ctxt) -> - (* Add the parsed script to the script-cache in order to avoid having to - re-parse when applying the operation at a later stage. *) - let (size, cost) = Script_ir_translator.script_size ex_script in - Gas.consume ctxt cost >>?= fun ctxt -> - Script_cache.insert ctxt destination (script, ex_script) size - >>?= fun ctxt -> return (ex_script, ctxt) - -let tickets_of_transaction ctxt ~destination ~parameters = +let tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters = match Contract.is_implicit destination with | Some _ -> return (None, ctxt) | None -> - (* TODO: #2351 - Avoid having to load the script from the cache. - After internal operations are in place we should be able to use the - typed script directly. - *) - parse_and_cache_script - ctxt - ~destination - ~get_non_cached_script:(fun ctxt -> - (* Look up the script from the context. *) - Contract.get_script ctxt destination >>=? fun (ctxt, script_opt) -> - match script_opt with - | None -> fail (Failed_to_get_script destination) - | Some script -> return (script, ctxt)) - >>=? fun (Script_ir_translator.Ex_script {arg_type; _}, ctxt) -> - Ticket_scanner.type_has_tickets ctxt arg_type + Ticket_scanner.type_has_tickets ctxt parameters_ty >>?= fun (has_tickets, ctxt) -> - (* Load the tickets from the parameters. *) - (* TODO: #2350 - Avoid having to decode and parse the [parameters] node. - After internal operations are in place we should be able to use the - typed script directly. - *) - Script.force_decode_in_context - ctxt - ~consume_deserialization_gas:When_needed - parameters - >>?= fun (expr, ctxt) -> - Ticket_scanner.tickets_of_node + Ticket_scanner.tickets_of_value ~include_lazy:true ctxt has_tickets - (Micheline.root expr) + parameters >>=? fun (tickets, ctxt) -> return (Some {destination; tickets}, ctxt) (** Extract tickets of an origination operation by scanning the storage. *) let tickets_of_origination ctxt ~preorigination script = - match preorigination with - | None -> fail Contract_not_originated - | Some destination -> - (* TODO: #2351 - Avoid having to load the script from the cache. - After internal operations are in place we should be able to use the - typed script directly. - *) - parse_and_cache_script - ctxt - ~destination - ~get_non_cached_script:(fun ctxt -> - (* For an origination operation we already have the script. *) - return (script, ctxt)) - >>=? fun ( Script_ir_translator.Ex_script - { - storage; - storage_type; - code = _; - arg_type = _; - views = _; - entrypoints = _; - code_size = _; - }, - ctxt ) -> (* Extract any tickets from the storage. Note that if the type of the contract storage does not contain tickets, storage is not scanned. *) - Ticket_scanner.type_has_tickets ctxt storage_type + Ticket_scanner.type_has_tickets ctxt script.Script_typed_ir.storage_type >>?= fun (has_tickets, ctxt) -> Ticket_scanner.tickets_of_value ctxt ~include_lazy:true has_tickets - storage - >|=? fun (tickets, ctxt) -> (Some {tickets; destination}, ctxt) + script.Script_typed_ir.storage + >|=? fun (tickets, ctxt) -> (Some {tickets; destination = preorigination}, ctxt) (* TODO: #2352 Extend operations scanning to support rollup-operations once ready. @@ -232,27 +162,21 @@ let tickets_of_origination ctxt ~preorigination script = originations and transactions. We will likely also need to support rollups. *) let tickets_of_operation ctxt - (Internal_operation {source = _; operation; nonce = _}) = + Script_typed_ir.(Internal_operation {source = _; operation; nonce = _}) = match operation with - | Reveal _ -> return (None, ctxt) | Transaction { + manager_transaction = { amount = _; - parameters; + parameters = _; entrypoint = _; destination = Destination.Contract destination; - } -> - tickets_of_transaction ctxt ~destination ~parameters - | Origination {delegate = _; script; credit = _} -> - tickets_of_origination ctxt ~preorigination:None script + }; parameters_ty; parameters} -> + tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters + | Origination {manager_origination = _; preorigination; parsed_script} -> + tickets_of_origination ctxt ~preorigination parsed_script | Delegation _ -> return (None, ctxt) - | Register_global_constant _ -> return (None, ctxt) - | Set_deposits_limit _ -> return (None, ctxt) - | Tx_rollup_origination -> return (None, ctxt) - | Tx_rollup_submit_batch _ -> return (None, ctxt) | Tx_rollup_commit _ -> return (None, ctxt) - | Sc_rollup_originate {kind = _; boot_sector = _} -> return (None, ctxt) - | Sc_rollup_add_messages {rollup = _; messages = _} -> return (None, ctxt) let add_transfer_to_token_map ctxt token_map {destination; tickets} = List.fold_left_es diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.mli b/src/proto_alpha/lib_protocol/ticket_operations_diff.mli index 1b2e7731f7a9..0c984a7c34b2 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.mli +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.mli @@ -48,5 +48,5 @@ type ticket_token_diff = private { tickets. *) val ticket_diffs_of_operations : Alpha_context.context -> - Alpha_context.packed_internal_operation list -> + Script_typed_ir.packed_internal_operation list -> (ticket_token_diff list * Alpha_context.context) tzresult Lwt.t -- GitLab From 41ad7891f278d1f6f293dbe3429af6973f9bf443 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 18 Feb 2022 23:27:07 +0100 Subject: [PATCH 38/63] Proto/Michelson: adapt test_ticket_accounting. --- .../michelson/test_ticket_accounting.ml | 63 ++++++++++++------- 1 file changed, 41 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index da849f548ff2..3dd97951048b 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -34,6 +34,7 @@ open Protocol open Alpha_context +open Error_monad_operators let wrap m = m >|= Environment.wrap_tzresult @@ -327,20 +328,33 @@ let originate_script block ~script ~storage ~src ~baker ~forges_tickets = in Incremental.finalize_block incr >|=? fun block -> (destination, script, block) -let origination_operation ~src ~script ~orig_contract = - Internal_operation - { - source = src; - operation = - Origination - { - delegate = None; - script; - credit = Tez.one; - preorigination = Some orig_contract; - }; - nonce = 1; - } +let origination_operation ~ctxt ~src ~script ~orig_contract = + Script_ir_translator.parse_script + ctxt + ~legacy:true + ~allow_forged_in_storage:true + script + >>=?? fun (Script_ir_translator.Ex_script parsed_script, ctxt) -> + let operation = + Script_typed_ir.Internal_operation + { + source = src; + operation = + Origination + { + manager_origination = + { + delegate = None; + script; + credit = Tez.one; + }; + preorigination = orig_contract; + parsed_script; + }; + nonce = 1; + } + in + return (operation, ctxt) let originate block ~src ~baker ~script ~storage ~forges_tickets = let open Lwt_tzresult_syntax in @@ -363,18 +377,23 @@ let transfer_operation ctxt ~src ~destination ~arg_type ~arg = arg) in return - ( Internal_operation + ( Script_typed_ir.Internal_operation { source = src; operation = Transaction { + manager_transaction = + { amount = Tez.zero; parameters = Script.lazy_expr @@ Micheline.strip_locations params_node; entrypoint = Entrypoint.default; destination = Destination.Contract destination; - }; + }; + parameters_ty = arg_type; + parameters = arg; + }; nonce = 1; }, ctxt ) @@ -1116,8 +1135,8 @@ let test_update_invalid_origination () = ~forges_tickets:true in let ctxt = Incremental.alpha_ctxt incr in - let operation = - origination_operation ~src ~orig_contract:destination ~script + let* (operation, ctxt) = + origination_operation ~ctxt ~src ~orig_contract:destination ~script in assert_fail_with ~loc:__LOC__ @@ -1156,8 +1175,8 @@ let test_update_valid_origination () = let* (_, ctxt) = wrap @@ Ticket_balance.adjust_balance ctxt red_self_token_hash ~delta:Z.one in - let operation = - origination_operation ~src:self ~orig_contract:originated ~script + let* (operation, ctxt) = + origination_operation ~ctxt ~src:self ~orig_contract:originated ~script in let* (_, ctxt) = let* (ticket_diffs, ctxt) = @@ -1202,8 +1221,8 @@ let test_update_self_origination () = wrap @@ Ticket_balance_key.ticket_balance_key ctxt ~owner:originated red_token in - let operation = - origination_operation ~src:self ~orig_contract:originated ~script + let* (operation, ctxt) = + origination_operation ~ctxt ~src:self ~orig_contract:originated ~script in let* (_, ctxt) = wrap -- GitLab From 665ab96a6d49bce7c421eda3b1efa0f424e98f25 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 11 Feb 2022 15:50:53 +0100 Subject: [PATCH 39/63] Proto/Michelson: adapt test_ticket_operations_diff. --- .../michelson/test_ticket_operations_diff.ml | 247 ++++++++---------- 1 file changed, 102 insertions(+), 145 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index adadc5dea93c..2aa14c048b46 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -33,7 +33,9 @@ *) open Protocol +open Script_typed_ir open Alpha_context +open Error_monad_operators (** A local non-private type that mirrors [Ticket_operations_diff.ticket_token_diff]. *) @@ -58,7 +60,7 @@ let big_map_updates_of_key_values ctxt key_values = wrap (Script_ir_translator.hash_comparable_data ctxt - Script_typed_ir.int_key + int_key (Script_int_repr.of_int key)) in return @@ -229,68 +231,37 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = let* incr = Incremental.begin_construction ~policy:Block.(By_account baker) block in + let ctxt = Incremental.alpha_ctxt incr in + Script_ir_translator.parse_script + ctxt + ~legacy:true + ~allow_forged_in_storage:true + script + >>=?? fun (Script_ir_translator.Ex_script parsed_script, ctxt) -> let operation = - Internal_operation + Script_typed_ir.Internal_operation { source = src; operation = Origination { + manager_origination = + { delegate = None; script; credit = Tez.one; - preorigination = Some orig_contract; + }; + preorigination = orig_contract; + parsed_script; }; nonce = 1; } in + let incr = Incremental.set_alpha_ctxt incr ctxt in return (orig_contract, operation, incr) -let register_global_constant_operation ~src = - Internal_operation - { - source = src; - operation = - Register_global_constant - {value = Script.lazy_expr @@ Expr.from_string "1"}; - nonce = 1; - } - -let reveal_operation ~src pk = - Internal_operation {source = src; operation = Reveal pk; nonce = 1} - let delegation_operation ~src = - Internal_operation {source = src; operation = Delegation None; nonce = 1} - -let set_deposits_limit_operation ~src = - Internal_operation - {source = src; operation = Set_deposits_limit None; nonce = 1} - -let sc_rollup_origination_operation ~src = - let rollup = Sc_rollup.Address.hash_string ["Dummy"] in - Internal_operation - { - source = src; - operation = Sc_rollup_add_messages {rollup; messages = []}; - nonce = 1; - } - -let sc_rollup_add_message ~src = - Internal_operation - { - source = src; - operation = - Sc_rollup_originate - { - kind = Sc_rollup.Kind.Example_arith; - boot_sector = Sc_rollup.PVM.boot_sector_of_string "Dummy"; - }; - nonce = 1; - } - -let tx_rollup_originate_operation ~src = - Internal_operation - {source = src; operation = Tx_rollup_origination; nonce = 1} + Script_typed_ir.Internal_operation {source = src; operation = Delegation None; nonce = 1} let originate block ~src ~baker ~script ~storage ~forges_tickets = let* (orig_contract, _script, block) = @@ -301,20 +272,39 @@ let originate block ~src ~baker ~script ~storage ~forges_tickets = in return (orig_contract, incr) -let transfer_operation ~src ~destination ~parameters = - Internal_operation - { - source = src; - operation = - Transaction - { - amount = Tez.zero; - parameters = Script.lazy_expr @@ Expr.from_string parameters; - entrypoint = Entrypoint.default; - destination = Destination.Contract destination; - }; - nonce = 1; - } +let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = + let open Lwt_tzresult_syntax in + let ctxt = Incremental.alpha_ctxt incr in + let* (params_node, ctxt) = + wrap + (Script_ir_translator.unparse_data + ctxt + Script_ir_translator.Readable + parameters_ty + parameters) + in + let incr = Incremental.set_alpha_ctxt incr ctxt in + return + ( Script_typed_ir.Internal_operation + { + source = src; + operation = + Transaction + { + manager_transaction = + { + amount = Tez.zero; + parameters = + Script.lazy_expr @@ Micheline.strip_locations params_node; + entrypoint = Entrypoint.default; + destination = Destination.Contract destination; + }; + parameters_ty; + parameters + }; + nonce = 1; + }, + incr ) let ticket_diffs_of_operations incr operations = wrap @@ -343,24 +333,26 @@ let ticket_big_map_script = code { CAR; NIL operation ; PAIR } } |} +let list_ticket_string_ty = + ticket_t Micheline.dummy_location string_key >>? fun ticket_ty -> + list_t Micheline.dummy_location ticket_ty + +let make_ticket (ticketer, contents, amount) = + Script_string.of_string contents >>?= fun contents -> + return {ticketer; contents; amount = nat amount} + +let make_tickets (l : (Contract.t * string * int) list) = + let* elements = List.map_es make_ticket l in + return {elements; length = List.length elements} + (** Test that no tickets are returned for operations that do not contain tickets. *) let test_non_ticket_operations () = let* (_baker, src, block) = init () in let* incr = Incremental.begin_construction block in - let pub_key = - Signature.Public_key.of_b58check_exn - "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" - in let operations = [ - register_global_constant_operation ~src; - reveal_operation ~src pub_key; delegation_operation ~src; - set_deposits_limit_operation ~src; - tx_rollup_originate_operation ~src; - sc_rollup_add_message ~src; - sc_rollup_origination_operation ~src; ] in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr operations in @@ -378,8 +370,8 @@ let test_transfer_to_non_ticket_contract () = ~storage:"Unit" ~forges_tickets:false in - let operation = - transfer_operation ~src ~destination:orig_contract ~parameters:"Unit" + let* (operation, incr) = + transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty:unit_t ~parameters:() in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] @@ -396,8 +388,10 @@ let test_transfer_empty_ticket_list () = ~storage:"{}" ~forges_tickets:false in - let operation = - transfer_operation ~src ~destination:orig_contract ~parameters:"{}" + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [] >>=?? fun parameters -> + let* (operation, incr) = + transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] @@ -415,11 +409,10 @@ let test_transfer_one_ticket () = ~storage:"{}" ~forges_tickets:false in - let parameters = - Printf.sprintf {|{Pair %S "white" 1}|} (Contract.to_b58check ticketer) - in - let operation = - transfer_operation ~src ~destination:orig_contract ~parameters + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [(ticketer, "white", 1)] >>=?? fun parameters -> + let* (operation, incr) = + transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs @@ -448,22 +441,10 @@ let test_transfer_multiple_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation = - let parameters = - let ticketer_addr = Contract.to_b58check ticketer in - Printf.sprintf - {|{ - Pair %S "red" 1; - Pair %S "blue" 2 ; - Pair %S "green" 3; - Pair %S "red" 4;} - |} - ticketer_addr - ticketer_addr - ticketer_addr - ticketer_addr - in - transfer_operation ~src ~destination:orig_contract ~parameters + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [(ticketer, "red", 1) ; (ticketer, "blue", 2) ; (ticketer, "green", 3) ; (ticketer, "red", 4)] >>=?? fun parameters -> + let* (operation, incr) = + transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs @@ -493,31 +474,8 @@ let test_transfer_multiple_tickets () = let test_transfer_different_tickets () = let* (baker, src, block) = init () in let* (ticketer1, ticketer2) = two_ticketers block in - let parameters = - let ticketer1_addr = Contract.to_b58check ticketer1 in - let ticketer2_addr = Contract.to_b58check ticketer2 in - Printf.sprintf - {|{ - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1; - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1 ; - Pair %S "red" 1; - Pair %S "green" 1; - Pair %S "blue" 1; } - |} - ticketer1_addr - ticketer1_addr - ticketer1_addr - ticketer2_addr - ticketer2_addr - ticketer2_addr - ticketer1_addr - ticketer1_addr - ticketer1_addr - in + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [(ticketer1, "red", 1) ; (ticketer1, "green", 1) ; (ticketer1, "blue", 1) ; (ticketer2, "red", 1) ; (ticketer2, "green", 1) ; (ticketer2, "blue", 1) ; (ticketer1, "red", 1) ; (ticketer1, "green", 1) ; (ticketer1, "blue", 1)] >>=?? fun parameters -> let* (destination, incr) = originate block @@ -527,7 +485,7 @@ let test_transfer_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation = transfer_operation ~src ~destination ~parameters in + let* (operation, incr) = transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt @@ -571,14 +529,8 @@ let test_transfer_different_tickets () = let test_transfer_to_two_contracts_with_different_tickets () = let* (baker, src, block) = init () in let* ticketer = one_ticketer block in - let parameters = - let ticketer_addr = Contract.to_b58check ticketer in - Printf.sprintf - {|{Pair %S "red" 1; Pair %S "green" 1; Pair %S "blue" 1; }|} - ticketer_addr - ticketer_addr - ticketer_addr - in + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [(ticketer, "red", 1) ; (ticketer, "green", 1) ; (ticketer, "blue", 1)] >>=?? fun parameters -> let* (destination1, incr) = originate block @@ -588,8 +540,8 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation1 = - transfer_operation ~src ~destination:destination1 ~parameters + let* (operation1, incr) = + transfer_operation ~incr ~src ~destination:destination1 ~parameters_ty ~parameters in let* block = Incremental.finalize_block incr in let* (destination2, incr) = @@ -601,8 +553,8 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let operation2 = - transfer_operation ~src ~destination:destination2 ~parameters + let* (operation2, incr) = + transfer_operation ~incr ~src ~destination:destination2 ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation1; operation2] @@ -907,15 +859,10 @@ let test_originate_and_transfer () = ~storage:"{}" ~forges_tickets:false in - let parameters = - Printf.sprintf - {|{Pair %S "red" 1; Pair %S "green" 1; Pair %S "blue" 1; }|} - ticketer_addr - ticketer_addr - ticketer_addr - in - let operation2 = - transfer_operation ~src ~destination:destination2 ~parameters + list_ticket_string_ty >>??= fun parameters_ty -> + make_tickets [(ticketer, "red", 1) ; (ticketer, "green", 1) ; (ticketer, "blue", 1)] >>=?? fun parameters -> + let* (operation2, incr) = + transfer_operation ~incr ~src ~destination:destination2 ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation1; operation2] @@ -1032,13 +979,23 @@ let test_transfer_big_map_with_tickets () = ~storage:"{}" ~forges_tickets:false in + ticket_t Micheline.dummy_location string_key >>??= fun value_type -> + big_map_t Micheline.dummy_location int_key value_type + >>??= fun parameters_ty -> let parameters = - Printf.sprintf "%d" @@ Z.to_int (Big_map.Id.unparse_to_z big_map_id) + { + id = Some big_map_id; + diff = {map = Big_map_overlay.empty; size = 0}; + key_type = int_key; + value_type; + } in - let operation = + let* (operation, incr) = transfer_operation + ~incr ~src:ticketer_contract ~destination:orig_contract + ~parameters_ty ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in -- GitLab From 812665e5f657756e9f5bdc9f6d3647b2eaa295fe Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 19 Feb 2022 11:16:57 +0100 Subject: [PATCH 40/63] SECTION 6: adapt apply_results. In order to remove Script_typed_ir.internal_operation. -- GitLab From dcd748c3ba88f2a29634289d46e73b9fd69a0be5 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 19 Feb 2022 22:52:56 +0100 Subject: [PATCH 41/63] Proto/Michelson: add types for internal operation results. Encodings have been copy/pasted and adapted from the ones in Operation_repr. Does not compile. --- src/proto_alpha/lib_protocol/apply_results.ml | 294 ++++++++++++++---- .../lib_protocol/apply_results.mli | 53 +++- 2 files changed, 276 insertions(+), 71 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index ab9b01cbb3ad..8755b248edaa 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -46,6 +46,53 @@ let error_encoding = let trace_encoding = make_trace_encoding error_encoding +type 'kind internal_operation_contents_result = + | Transaction : + Alpha_context.manager_transaction + -> Kind.transaction internal_operation_contents_result + | Origination : { + manager_origination : Alpha_context.manager_origination; + preorigination : Contract.t; + } + -> Kind.origination internal_operation_contents_result + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation internal_operation_contents_result + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit internal_operation_contents_result + +type 'kind internal_operation_result = { + source : Contract.contract; + operation : 'kind internal_operation_contents_result; + nonce : int; +} + +type packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation_result + -> packed_internal_operation_result + +let result_of_internal_operation (type kind) + ({source; operation; nonce} : kind Script_typed_ir.internal_operation) : + kind internal_operation_result = + let operation : kind internal_operation_contents_result = + match operation with + | Script_typed_ir.Transaction {manager_transaction; _} -> + Transaction manager_transaction + | Script_typed_ir.Origination {manager_origination; preorigination; _} -> + Origination {manager_origination; preorigination} + | Script_typed_ir.Delegation delegate -> Delegation delegate + | Script_typed_ir.Tx_rollup_commit tx_rollup_commit -> + Tx_rollup_commit tx_rollup_commit + in + {source; operation; nonce} + +let results_of_internal_operations l = + let f (Script_typed_ir.Internal_operation internal_op) = + Internal_operation_result (result_of_internal_operation internal_op) in + List.map f l + type successful_transaction_result = | Transaction_to_contract_result of { storage : Script.expr option; @@ -157,10 +204,16 @@ type 'kind manager_operation_result = | Skipped : 'kind Kind.manager -> 'kind manager_operation_result [@@coq_force_gadt] -type packed_internal_operation_result = - | Internal_operation_result : - 'kind internal_operation * 'kind manager_operation_result - -> packed_internal_operation_result +type packed_operation_result = + | Operation_result : + 'kind internal_operation_result * 'kind manager_operation_result + -> packed_operation_result + +let pack_operation_result (type kind) + (internal_op : kind Script_typed_ir.internal_operation) + (manager_op : kind manager_operation_result) = + let internal_op = result_of_internal_operation internal_op in + Operation_result (internal_op, manager_op) module Manager_result = struct type 'kind case = @@ -169,8 +222,9 @@ module Manager_result = struct encoding : 'a Data_encoding.t; kind : 'kind Kind.manager; iselect : - packed_internal_operation_result -> - ('kind internal_operation * 'kind manager_operation_result) option; + packed_operation_result -> + ('kind internal_operation_result * 'kind manager_operation_result) + option; select : packed_successful_manager_operation_result -> 'kind successful_manager_operation_result option; @@ -241,10 +295,7 @@ module Manager_result = struct obj2 (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) - ~iselect:(function - | Internal_operation_result (({operation = Reveal _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Reveal_result _ as op) -> Some op | _ -> None) @@ -322,8 +373,7 @@ module Manager_result = struct ~op_case:Operation.Encoding.Manager_operations.transaction_case ~encoding:transaction_to_contract_case ~iselect:(function - | Internal_operation_result (({operation = Transaction _; _} as op), res) - -> + | Operation_result (({operation = Transaction _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -346,8 +396,7 @@ module Manager_result = struct (dft "paid_storage_size_diff" z Z.zero) (opt "lazy_storage_diff" Lazy_storage.encoding)) ~iselect:(function - | Internal_operation_result (({operation = Origination _; _} as op), res) - -> + | Operation_result (({operation = Origination _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -401,11 +450,7 @@ module Manager_result = struct (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (dft "storage_size" z Z.zero) (req "global_address" Script_expr_hash.encoding)) - ~iselect:(function - | Internal_operation_result - (({operation = Register_global_constant _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Register_global_constant_result _ as op) -> Some op @@ -443,8 +488,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) ~iselect:(function - | Internal_operation_result (({operation = Delegation _; _} as op), res) - -> + | Operation_result (({operation = Delegation _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -466,11 +510,7 @@ module Manager_result = struct obj2 (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) - ~iselect:(function - | Internal_operation_result - (({operation = Set_deposits_limit _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Set_deposits_limit_result _ as op) -> Some op @@ -493,11 +533,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (req "originated_rollup" Tx_rollup.encoding)) - ~iselect:(function - | Internal_operation_result - (({operation = Tx_rollup_origination; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Tx_rollup_origination_result _ as op) -> Some op @@ -532,11 +568,7 @@ module Manager_result = struct (req "balance_updates" Receipt.balance_updates_encoding) (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) - ~iselect:(function - | Internal_operation_result - (({operation = Tx_rollup_submit_batch _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Tx_rollup_submit_batch_result _ as op) -> Some op @@ -560,8 +592,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) ~iselect:(function - | Internal_operation_result - (({operation = Tx_rollup_commit _; _} as op), res) -> + | Operation_result (({operation = Tx_rollup_commit _; _} as op), res) -> Some (op, res) | _ -> None) ~select:(function @@ -586,11 +617,7 @@ module Manager_result = struct (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (req "size" z)) - ~iselect:(function - | Internal_operation_result - (({operation = Sc_rollup_originate _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Sc_rollup_originate_result _ as op) -> Some op @@ -618,11 +645,7 @@ module Manager_result = struct (req "consumed_gas" Gas.Arith.n_integral_encoding) (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero) (req "inbox_after" Sc_rollup.Inbox.encoding)) - ~iselect:(function - | Internal_operation_result - (({operation = Sc_rollup_add_messages _; _} as op), res) -> - Some (op, res) - | _ -> None) + ~iselect:(fun _ -> None) ~select:(function | Successful_manager_result (Sc_rollup_add_messages_result _ as op) -> Some op @@ -637,10 +660,153 @@ module Manager_result = struct {consumed_gas = consumed_milligas; inbox_after}) end +module Internal_result = struct + open Data_encoding + + type packed_internal_operation_contents_result = + | Piocr : + 'kind internal_operation_contents_result + -> packed_internal_operation_contents_result + + type 'kind case = + | MCase : { + tag : int; + name : string; + encoding : 'a Data_encoding.t; + select : packed_internal_operation_contents_result -> 'kind internal_operation_contents_result option; + proj : 'kind internal_operation_contents_result -> 'a; + inj : 'a -> 'kind internal_operation_contents_result; + } + -> 'kind case + [@@coq_force_gadt] + + let[@coq_axiom_with_reason "gadt"] transaction_case = + MCase + { + tag = Operation.Encoding.transaction_tag; + name = "transaction"; + encoding = + obj3 + (req "amount" Tez.encoding) + (req "destination" Destination.encoding) + (opt + "parameters" + (obj2 + (req "entrypoint" Entrypoint.smart_encoding) + (req "value" Script.lazy_expr_encoding))); + select = (function Piocr (Transaction _ as op) -> Some op | _ -> None); + proj = + (function + | Transaction {amount; destination; parameters; entrypoint} -> + let parameters = + if + Script_repr.is_unit_parameter parameters + && Entrypoint.is_default entrypoint + then None + else Some (entrypoint, parameters) + in + (amount, destination, parameters)); + inj = + (fun (amount, destination, parameters) -> + let (entrypoint, parameters) = + match parameters with + | None -> (Entrypoint.default, Script.unit_parameter) + | Some (entrypoint, value) -> (entrypoint, value) + in + Transaction {amount; destination; parameters; entrypoint}); + } + + let[@coq_axiom_with_reason "gadt"] origination_case = + MCase + { + tag = Operation.Encoding.origination_tag; + name = "origination"; + encoding = + obj4 + (req "balance" Tez.encoding) + (opt "delegate" Signature.Public_key_hash.encoding) + (req "script" Script.encoding) + (req "preorigination" Contract.encoding); + select = (function Piocr (Origination _ as op) -> Some op | _ -> None); + proj = + (function + | Origination + {manager_origination = {credit; delegate; script}; preorigination} + -> + (credit, delegate, script, preorigination)); + inj = + (fun (credit, delegate, script, preorigination) -> + Origination + {manager_origination = {credit; delegate; script}; preorigination}); + } + + let[@coq_axiom_with_reason "gadt"] delegation_case = + MCase + { + tag = Operation.Encoding.delegation_tag; + name = "delegation"; + encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); + select = (function Piocr (Delegation _ as op) -> Some op | _ -> None); + proj = (function Delegation key -> key); + inj = (fun key -> Delegation key); + } + + let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + MCase + { + tag = 3; + name = "tx_rollup_commit"; + encoding = + obj2 + (req "tx_rollup" Tx_rollup.encoding) + (req "commitment" Tx_rollup_commitments.Commitment.encoding); + select = + (function Piocr (Tx_rollup_commit _ as op) -> Some op | _ -> None); + proj = + (function + | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment)); + inj = + (fun (tx_rollup, commitment) -> + Tx_rollup_commit {tx_rollup; commitment}); + } +end + let internal_operation_result_encoding : packed_internal_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) = + case + (Tag ires_case.tag) + ~title:ires_case.name + (merge_objs + (obj3 + (req "kind" (constant ires_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + ires_case.encoding) + (fun (Internal_operation_result op) -> + match ires_case.select (Piocr op.operation) with + | Some op_contents -> + Some (((), op.source, op.nonce), ires_case.proj op_contents) + | None -> None) + (fun (((), source, nonce), op) -> + let op = {source; operation = ires_case.inj op; nonce} in + Internal_operation_result op) + in + def "apply_results.alpha.internal_operation_result" + @@ union + [ + make Internal_result.transaction_case; + make Internal_result.origination_case; + make Internal_result.delegation_case; + make Internal_result.tx_rollup_commit_case; + ] + +let operation_result_encoding : + packed_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) = let (Operation.Encoding.Manager_operations.MCase op_case) = res_case.op_case in @@ -652,29 +818,25 @@ let internal_operation_result_encoding : (req "kind" (constant op_case.name)) (req "source" Contract.encoding) (req "nonce" uint16)) - (merge_objs op_case.encoding (obj1 (req "result" res_case.t)))) + (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) (fun op -> match res_case.iselect op with | Some (op, res) -> - Some (((), op.source, op.nonce), (op_case.proj op.operation, res)) + Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) | None -> None) (fun (((), source, nonce), (op, res)) -> - let op = {source; operation = op_case.inj op; nonce} in - Internal_operation_result (op, res)) + let op = {source; operation = ires_case.inj op; nonce} in + Operation_result (op, res)) in - def "operation.alpha.internal_operation_result" + def "apply_results.alpha.operation_result" @@ union [ - make Manager_result.reveal_case; - make Manager_result.transaction_case; - make Manager_result.origination_case; - make Manager_result.delegation_case; - make Manager_result.register_global_constant_case; - make Manager_result.set_deposits_limit_case; - make Manager_result.tx_rollup_origination_case; - make Manager_result.tx_rollup_submit_batch_case; - make Manager_result.sc_rollup_originate_case; - make Manager_result.sc_rollup_add_messages_case; + make Manager_result.transaction_case Internal_result.transaction_case; + make Manager_result.origination_case Internal_result.origination_case; + make Manager_result.delegation_case Internal_result.delegation_case; + make + Manager_result.tx_rollup_commit_case + Internal_result.tx_rollup_commit_case; ] let successful_manager_operation_result_encoding : @@ -738,7 +900,7 @@ type 'kind contents_result = | Manager_operation_result : { balance_updates : Receipt.balance_updates; operation_result : 'kind manager_operation_result; - internal_operation_results : packed_internal_operation_result list; + internal_operation_results : packed_operation_result list; } -> 'kind Kind.manager contents_result @@ -1011,7 +1173,7 @@ module Encoding = struct (req "operation_result" res_case.t) (dft "internal_operation_results" - (list internal_operation_result_encoding) + (list operation_result_encoding) []); select = (function diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 7fcdc6979d04..46afa786686d 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -33,6 +33,37 @@ open Alpha_context +type 'kind internal_operation_contents_result = + | Transaction : + Alpha_context.manager_transaction + -> Kind.transaction internal_operation_contents_result + | Origination : { + manager_origination : Alpha_context.manager_origination; + preorigination : Contract.t; + } + -> Kind.origination internal_operation_contents_result + | Delegation : + Signature.Public_key_hash.t option + -> Kind.delegation internal_operation_contents_result + | Tx_rollup_commit : + Alpha_context.manager_tx_rollup_commit + -> Kind.tx_rollup_commit internal_operation_contents_result + +type 'kind internal_operation_result = { + source : Contract.contract; + operation : 'kind internal_operation_contents_result; + nonce : int; +} + +type packed_internal_operation_result = + | Internal_operation_result : + 'kind internal_operation_result + -> packed_internal_operation_result + +val results_of_internal_operations : + Script_typed_ir.packed_internal_operation list -> + packed_internal_operation_result list + (** Result of applying a {!Operation.t}. Follows the same structure. *) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -87,7 +118,7 @@ and 'kind contents_result = | Manager_operation_result : { balance_updates : Receipt.balance_updates; operation_result : 'kind manager_operation_result; - internal_operation_results : packed_internal_operation_result list; + internal_operation_results : packed_operation_result list; } -> 'kind Kind.manager contents_result @@ -196,11 +227,23 @@ and packed_successful_manager_operation_result = | Successful_manager_result : 'kind successful_manager_operation_result -> packed_successful_manager_operation_result +and packed_operation_result = + | Operation_result : + 'kind internal_operation_result * 'kind manager_operation_result + -> packed_operation_result -and packed_internal_operation_result = - | Internal_operation_result : - 'kind internal_operation * 'kind manager_operation_result - -> packed_internal_operation_result +val result_of_internal_operation : + 'kind Script_typed_ir.internal_operation -> 'kind internal_operation_result + +val pack_operation_result : + 'kind Script_typed_ir.internal_operation -> + 'kind manager_operation_result -> + packed_operation_result + +val operation_result_encoding : packed_operation_result Data_encoding.t + +val internal_operation_result_encoding : + packed_internal_operation_result Data_encoding.t val pack_migration_operation_results : Migration.origination_result list -> -- GitLab From 45286910381f5da465cf6dc8f2e6680a1e7debb0 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 19 Feb 2022 23:32:56 +0100 Subject: [PATCH 42/63] Proto/Michelson: add a manager_kind function for internal operations. It will be used to create Apply_results' entities in Apply. Does not compile. --- src/proto_alpha/lib_protocol/script_typed_ir.ml | 10 ++++++++++ src/proto_alpha/lib_protocol/script_typed_ir.mli | 5 +++++ 2 files changed, 15 insertions(+) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 0e76f2ef70ce..a7f1176e58fa 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1435,6 +1435,16 @@ and 'kind manager_operation = Alpha_context.manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +let manager_kind : type kind. kind manager_operation -> kind Kind.manager = + function + | Transaction _ -> Kind.Transaction_manager_kind + | Origination _ -> Kind.Origination_manager_kind + | Delegation _ -> Kind.Delegation_manager_kind + | Tx_rollup_commit _ -> Kind.Tx_rollup_commit_manager_kind + let unty_internal_operation : type kind. kind internal_operation -> kind Alpha_context.internal_operation = diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 42a36993102e..a368a0e20879 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1562,6 +1562,11 @@ and 'kind manager_operation = Alpha_context.manager_tx_rollup_commit -> Kind.tx_rollup_commit manager_operation +type packed_manager_operation = + | Manager : 'kind manager_operation -> packed_manager_operation + +val manager_kind : 'kind manager_operation -> 'kind Kind.manager + (** [unty_internal_operation iop] removes the typing information inside [iop]. *) val unty_internal_operation : -- GitLab From 2a7aaee1351c9042c6e87b3e9f9d898f698c862a Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 19 Feb 2022 23:22:32 +0100 Subject: [PATCH 43/63] Proto/Michelson: use new internal operation results types in Apply. Internal_operation_replay is simplified to just the nonce, because it is the only field used and it simplifies the error registration. Does not compile. --- src/proto_alpha/lib_protocol/apply.ml | 35 ++++++++++++-------------- src/proto_alpha/lib_protocol/apply.mli | 3 +-- 2 files changed, 17 insertions(+), 21 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 26a817868015..89ae8b65f204 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -542,8 +542,7 @@ let () = type error += | (* `Temporary *) Wrong_voting_period of {expected : int32; provided : int32} -type error += - | (* `Permanent *) Internal_operation_replay of packed_internal_operation +type error += (* `Permanent *) Internal_operation_replay of {nonce : int} type denunciation_kind = Preendorsement | Endorsement | Block @@ -625,14 +624,14 @@ let () = ~id:"internal_operation_replay" ~title:"Internal operation replay" ~description:"An internal operation was emitted twice by a script" - ~pp:(fun ppf (Internal_operation {nonce; _}) -> + ~pp:(fun ppf nonce -> Format.fprintf ppf "Internal operation %d was emitted twice by a script" nonce) - Operation.internal_operation_encoding - (function Internal_operation_replay op -> Some op | _ -> None) - (fun op -> Internal_operation_replay op) ; + Data_encoding.(obj1 (req "nonce" int16)) + (function Internal_operation_replay {nonce} -> Some nonce | _ -> None) + (fun nonce -> Internal_operation_replay {nonce}) ; register_error_kind `Permanent ~id:"block.invalid_denunciation" @@ -1342,9 +1341,8 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = match worklist with | [] -> Lwt.return (Success ctxt, List.rev applied) | Script_typed_ir.Internal_operation ({source; operation; nonce} as op) :: rest -> ( - let op_for_result = Script_typed_ir.unty_internal_operation op in (if internal_nonce_already_recorded ctxt nonce then - fail (Internal_operation_replay (Internal_operation op_for_result)) + fail (Internal_operation_replay {nonce}) else let ctxt = record_internal_nonce ctxt nonce in apply_manager_operation_content @@ -1359,22 +1357,21 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = >>= function | Error errors -> let result = - Internal_operation_result - (op_for_result, Failed (manager_kind op_for_result.operation, errors)) + pack_operation_result + op (Failed (Script_typed_ir.manager_kind op.operation, errors)) in let skipped = List.rev_map (fun (Script_typed_ir.Internal_operation op) -> - let op_for_result = Script_typed_ir.unty_internal_operation op in - Internal_operation_result - (op_for_result, Skipped (manager_kind op_for_result.operation))) + pack_operation_result + op (Skipped (Script_typed_ir.manager_kind op.operation))) rest in Lwt.return (Failure, List.rev (skipped @ result :: applied)) | Ok (ctxt, result, emitted) -> apply ctxt - (Internal_operation_result (op_for_result, Applied result) :: applied) + (pack_operation_result op (Applied result) :: applied) (emitted @ rest)) in apply ctxt [] ops @@ -1605,7 +1602,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id ~gas_consumed_in_precheck (op : kind Kind.manager contents) : (success_or_failure * kind manager_operation_result - * packed_internal_operation_result list) + * packed_operation_result list) Lwt.t = let[@coq_match_with_default] (Manager_operation { @@ -1645,13 +1642,13 @@ let apply_manager_contents (type kind) ctxt mode chain_id | Ok (ctxt, storage_limit, operation_results) -> ( List.fold_left_es (fun (ctxt, storage_limit, res) iopr -> - let (Internal_operation_result (op, mopr)) = iopr in + let (Operation_result (op, mopr)) = iopr in match mopr with | Applied smopr -> burn_storage_fees ctxt smopr ~storage_limit ~payer:source >>=? fun (ctxt, storage_limit, smopr) -> let iopr = - Internal_operation_result (op, Applied smopr) + Operation_result (op, Applied smopr) in return (ctxt, storage_limit, iopr :: res) | _ -> return (ctxt, storage_limit, iopr :: res)) @@ -1911,9 +1908,9 @@ let mark_backtracked results = op.internal_operation_results; }, mark_contents_list rest ) - and mark_internal_operation_results (Internal_operation_result (kind, result)) + and mark_internal_operation_results (Operation_result (kind, result)) = - Internal_operation_result (kind, mark_manager_operation_result result) + Operation_result (kind, mark_manager_operation_result result) and mark_manager_operation_result : type kind. kind manager_operation_result -> kind manager_operation_result = function diff --git a/src/proto_alpha/lib_protocol/apply.mli b/src/proto_alpha/lib_protocol/apply.mli index 3083094a7151..d0651ee2fff9 100644 --- a/src/proto_alpha/lib_protocol/apply.mli +++ b/src/proto_alpha/lib_protocol/apply.mli @@ -36,8 +36,7 @@ open Alpha_context open Apply_results -type error += - | (* `Permanent *) Internal_operation_replay of packed_internal_operation +type error += (* `Permanent *) Internal_operation_replay of {nonce : int} type error += (* Permanent *) Gas_quota_exceeded_init_deserialize -- GitLab From 030ae65f19deaa0ae9e2b98e2292cbfcecbd28fc Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sat, 19 Feb 2022 23:45:54 +0100 Subject: [PATCH 44/63] Proto/Michelson: other consequences of Apply_results' types and simplifications. Does not compile. --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 6 ++---- src/proto_alpha/lib_protocol/test/helpers/incremental.ml | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 81fc91217352..2aa326ed14de 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -480,10 +480,8 @@ let unparse_key_hash ~loc ctxt mode k = (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = - let piop = unty_packed_internal_operation piop in - let bytes = - Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding piop - in + let Internal_operation iop = piop in + let bytes = Bytes.of_string @@ string_of_int iop.nonce in Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> (Bytes (loc, bytes), ctxt) diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index d53c8a63ec7a..e0e16d9446db 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -143,7 +143,7 @@ let detect_script_failure : in detect_script_failure operation_result >>? fun () -> List.iter_e - (fun (Internal_operation_result (_, r)) -> detect_script_failure r) + (fun (Operation_result (_, r)) -> detect_script_failure r) internal_operation_results in function -- GitLab From 1ff3a93a1b4b6976d3eeabfd622b33bd37f1eccb Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sun, 20 Feb 2022 23:44:29 +0100 Subject: [PATCH 45/63] Proto/Plugin: use new internal operations and results types. Does not compile. --- src/proto_alpha/lib_plugin/plugin.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index c3303dd852c3..f50e1650528b 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1461,8 +1461,8 @@ module View_helpers = struct in match operations with | [ - Internal_operation - {operation = Transaction {destination; parameters; _}; _}; + Script_typed_ir.Internal_operation + {operation = Transaction {manager_transaction = {destination; parameters; _}; _}; _}; ] when Destination.equal destination (Contract callback) -> ok parameters @@ -1601,7 +1601,7 @@ module RPC = struct (storage, operations, lazy_storage_diff)) (obj3 (req "storage" Script.expr_encoding) - (req "operations" (list Operation.internal_operation_encoding)) + (req "operations" (list Apply_results.internal_operation_result_encoding)) (opt "lazy_storage_diff" Lazy_storage.encoding)) let trace_code_input_encoding = run_code_input_encoding @@ -1621,7 +1621,7 @@ module RPC = struct (storage, operations, trace, lazy_storage_diff)) (obj4 (req "storage" Script.expr_encoding) - (req "operations" (list Operation.internal_operation_encoding)) + (req "operations" (list Apply_results.internal_operation_result_encoding)) (req "trace" trace_encoding) (opt "lazy_storage_diff" Lazy_storage.encoding)) @@ -2245,7 +2245,7 @@ module RPC = struct lazy_storage_diff; _; }, - _ ) -> (storage, Script_typed_ir.unty_operations operations, lazy_storage_diff)) ; + _ ) -> (storage, Apply_results.results_of_internal_operations operations, lazy_storage_diff)) ; Registration.register0 ~chunked:true S.trace_code @@ -2311,7 +2311,7 @@ module RPC = struct lazy_storage_diff; _; }, - trace ) -> (storage, Script_typed_ir.unty_operations operations, trace, lazy_storage_diff)) ; + trace ) -> (storage, Apply_results.results_of_internal_operations operations, trace, lazy_storage_diff)) ; Registration.register0 ~chunked:true S.run_view @@ -2400,7 +2400,7 @@ module RPC = struct >>=? fun ({Script_interpreter.operations; _}, (_, _)) -> View_helpers.extract_parameter_from_operations entrypoint - (Script_typed_ir.unty_operations operations) + operations viewer_contract >>?= fun parameter -> Lwt.return (Script_repr.force_decode parameter)) ; Registration.register0 -- GitLab From b118e6bdb58aea8c72f77cbb81499cb427f04bcc Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sun, 20 Feb 2022 23:22:07 +0100 Subject: [PATCH 46/63] Proto/Client: use new internal operation results types. --- .../lib_client/client_proto_programs.ml | 4 +-- .../lib_client/client_proto_programs.mli | 8 ++--- src/proto_alpha/lib_client/injection.ml | 8 ++--- .../lib_client/michelson_v1_error_reporter.ml | 7 ++--- .../lib_client/operation_result.ml | 31 ++++++++++++++----- .../lib_client/operation_result.mli | 5 ++- .../lib_client/protocol_client_context.ml | 2 +- 7 files changed, 42 insertions(+), 23 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 518aa3c40677..b483f29fe220 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -86,7 +86,7 @@ let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed = %a@]@]@." print_expr storage - (Format.pp_print_list Operation_result.pp_internal_operation) + (Format.pp_print_list Operation_result.pp_internal_operation_result) operations (fun ppf -> function | None -> () @@ -109,7 +109,7 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed = %a@]@]@." print_expr storage - (Format.pp_print_list Operation_result.pp_internal_operation) + (Format.pp_print_list Operation_result.pp_internal_operation_result) operations (fun ppf -> function | None -> () diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index a2e74ec62080..c5020b05ee3e 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -73,7 +73,7 @@ val run : chain:Shell_services.chain -> block:Shell_services.block -> run_params -> - (Script.expr * packed_internal_operation list * Lazy_storage.diffs option) + (Script.expr * Apply_results.packed_internal_operation_result list * Lazy_storage.diffs option) tzresult Lwt.t @@ -83,7 +83,7 @@ val trace : block:Shell_services.block -> run_params -> (Script.expr - * packed_internal_operation list + * Apply_results.packed_internal_operation_result list * Script_typed_ir.execution_trace * Lazy_storage.diffs option) tzresult @@ -99,7 +99,7 @@ val print_run_result : show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr - * packed_internal_operation list + * Apply_results.packed_internal_operation_result list * Lazy_storage.diffs option) tzresult -> unit tzresult Lwt.t @@ -109,7 +109,7 @@ val print_trace_result : show_source:bool -> parsed:Michelson_v1_parser.parsed -> (Script_repr.expr - * packed_internal_operation list + * Apply_results.packed_internal_operation_result list * Script_typed_ir.execution_trace * Lazy_storage.diffs option) tzresult -> diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index ecf5fb52bbd8..486e2ede7de5 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -337,7 +337,7 @@ let estimated_gas_single (type kind) in consumed_gas operation_result >>? fun gas -> List.fold_left_e - (fun acc (Internal_operation_result (_, r)) -> + (fun acc (Operation_result (_, r)) -> consumed_gas r >>? fun gas -> Ok (Gas.Arith.add acc gas)) gas internal_operation_results @@ -379,7 +379,7 @@ let estimated_storage_single (type kind) ~tx_rollup_origination_size in storage_size_diff operation_result >>? fun storage -> List.fold_left_e - (fun acc (Internal_operation_result (_, r)) -> + (fun acc (Operation_result (_, r)) -> storage_size_diff r >>? fun storage -> Ok (Z.add acc storage)) storage internal_operation_results @@ -433,7 +433,7 @@ let originated_contracts_single (type kind) originated_contracts operation_result >>? fun contracts -> let contracts = List.rev contracts in List.fold_left_e - (fun acc (Internal_operation_result (_, r)) -> + (fun acc (Operation_result (_, r)) -> originated_contracts r >>? fun contracts -> Ok (List.rev_append contracts acc)) contracts @@ -479,7 +479,7 @@ let detect_script_failure : type kind. kind operation_metadata -> _ = in detect_script_failure operation_result >>? fun () -> List.iter_e - (fun (Internal_operation_result (_, r)) -> detect_script_failure r) + (fun (Operation_result (_, r)) -> detect_script_failure r) internal_operation_results in function diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index e74e64be2b3b..9ff59733e718 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -376,12 +376,11 @@ let report_errors ~details ~show_source ?parsed ppf errs = (parsed, hilights) ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest - | Environment.Ecoproto_error (Apply.Internal_operation_replay op) :: rest -> + | Environment.Ecoproto_error (Apply.Internal_operation_replay {nonce}) :: rest -> Format.fprintf ppf - "@[Internal operation replay attempt:@,%a@]" - Operation_result.pp_internal_operation - op ; + "@[Internal operation replay attempt:@,%d@]" + nonce ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest | Environment.Ecoproto_error Gas.Gas_limit_too_high :: rest -> diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index a9297e1e785d..55ad06e410db 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -58,8 +58,7 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf expr) ; pp_result ppf result ; Format.fprintf ppf "@]" - | Origination {delegate; credit; script = {code; storage}} - -> + | Origination {delegate; credit; script = {code; storage}} -> Format.fprintf ppf "@[%s:@,From: %a@,Credit: %s%a" @@ -320,6 +319,18 @@ let pp_balance_updates_opt ppf balance_updates = pp_balance_updates balance_updates +let manager_operation (type kind) + (operation : kind internal_operation_contents_result) : + kind manager_operation = + match operation with + | Transaction manager_transaction -> + Alpha_context.Transaction manager_transaction + | Origination {manager_origination; preorigination = _} -> + Alpha_context.Origination manager_origination + | Delegation delegate -> Alpha_context.Delegation delegate + | Tx_rollup_commit tx_rollup_commit -> + Alpha_context.Tx_rollup_commit tx_rollup_commit + let pp_manager_operation_contents_and_result ppf ( Manager_operation {source; fee; operation; counter; gas_limit; storage_limit}, @@ -624,13 +635,14 @@ let pp_manager_operation_contents_and_result ppf Format.fprintf ppf "@,@[Internal operations:@ %a@]" - (Format.pp_print_list (fun ppf (Internal_operation_result (op, res)) -> + (Format.pp_print_list (fun ppf (Operation_result (op, res)) -> + let operation = manager_operation op.operation in pp_manager_operation_content op.source false pp_result ppf - (op.operation, res))) + (operation, res))) internal_operation_results) ; Format.fprintf ppf "@]" @@ -792,11 +804,16 @@ let pp_operation_result ppf pp_contents_and_result_list ppf contents_and_result_list ; Format.fprintf ppf "@]@." -let pp_internal_operation ppf - (Internal_operation {source; operation; nonce = _}) = +let pp_internal_operation_result ppf + (Apply_results.Internal_operation_result op) = + let operation = manager_operation op.operation in pp_manager_operation_content - source + op.source true (fun _ppf () -> ()) ppf (operation, ()) + +let pp_internal_operation ppf Script_typed_ir.(Internal_operation op) = + let op = result_of_internal_operation op in + pp_internal_operation_result ppf (Internal_operation_result op) diff --git a/src/proto_alpha/lib_client/operation_result.mli b/src/proto_alpha/lib_client/operation_result.mli index cc03abfcd36b..40157341b536 100644 --- a/src/proto_alpha/lib_client/operation_result.mli +++ b/src/proto_alpha/lib_client/operation_result.mli @@ -27,7 +27,10 @@ open Protocol open Alpha_context val pp_internal_operation : - Format.formatter -> packed_internal_operation -> unit + Format.formatter -> Script_typed_ir.packed_internal_operation -> unit + +val pp_internal_operation_result : + Format.formatter -> Apply_results.packed_internal_operation_result -> unit val pp_operation_result : Format.formatter -> diff --git a/src/proto_alpha/lib_client/protocol_client_context.ml b/src/proto_alpha/lib_client/protocol_client_context.ml index 511a6d937f85..e765c06f3fc3 100644 --- a/src/proto_alpha/lib_client/protocol_client_context.ml +++ b/src/proto_alpha/lib_client/protocol_client_context.ml @@ -206,7 +206,7 @@ let () = @@ def "operation" ["internal"] - Protocol.Alpha_context.Operation.internal_operation_encoding ; + Protocol.Apply_results.internal_operation_result_encoding ; register @@ def "operation" -- GitLab From 6f2cb5c6ab75bfe413293111ea5823eb5e9f3652 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Fri, 18 Feb 2022 09:11:10 +0100 Subject: [PATCH 47/63] SECTION 7: cleaning up. -- GitLab From 3cf1e9ea2cf69755afe70f1aec551296b962e7c7 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Sun, 20 Feb 2022 23:56:01 +0100 Subject: [PATCH 48/63] Proto/Michelson: remove Operation_repr.internal_operation. And what depends on it. --- .../lib_protocol/alpha_context.mli | 11 ----- .../lib_protocol/operation_repr.ml | 48 ------------------- .../lib_protocol/operation_repr.mli | 11 ----- .../lib_protocol/script_typed_ir.ml | 22 --------- .../lib_protocol/script_typed_ir.mli | 15 ------ 5 files changed, 107 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index e7195b900fc3..a25e6a131dd5 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2382,12 +2382,6 @@ and _ manager_operation = and counter = Z.t -type 'kind internal_operation = { - source : Contract.contract; - operation : 'kind manager_operation; - nonce : int; -} - type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation @@ -2404,9 +2398,6 @@ type packed_operation = { protocol_data : packed_protocol_data; } -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation - val manager_kind : 'kind manager_operation -> 'kind Kind.manager module Operation : sig @@ -2464,8 +2455,6 @@ module Operation : sig val check_signature : public_key -> Chain_id.t -> _ operation -> unit tzresult - val internal_operation_encoding : packed_internal_operation Data_encoding.t - val pack : 'kind operation -> packed_operation type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index fbacac217dbc..6e0dfdecadde 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -313,12 +313,6 @@ let manager_kind : type kind. kind manager_operation -> kind Kind.manager = | Sc_rollup_originate _ -> Kind.Sc_rollup_originate_manager_kind | Sc_rollup_add_messages _ -> Kind.Sc_rollup_add_messages_manager_kind -type 'kind internal_operation = { - source : Contract_repr.contract; - operation : 'kind manager_operation; - nonce : int; -} - type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation @@ -338,9 +332,6 @@ type packed_operation = { let pack ({shell; protocol_data} : _ operation) : packed_operation = {shell; protocol_data = Operation_data protocol_data} -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation - let rec contents_list_to_list : type a. a contents_list -> _ = function | Single o -> [Contents o] | Cons (o, os) -> Contents o :: contents_list_to_list os @@ -614,32 +605,6 @@ module Encoding = struct (fun (rollup, messages) -> Sc_rollup_add_messages {rollup; messages}); } - - let encoding = - let make (MCase {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 -> Manager (inj x)) - in - union - ~tag_size:`Uint8 - [ - make reveal_case; - make transaction_case; - make origination_case; - make delegation_case; - make register_global_constant_case; - make set_deposits_limit_case; - make tx_rollup_origination_case; - make tx_rollup_submit_batch_case; - make tx_rollup_commit_case; - make sc_rollup_originate_case; - make sc_rollup_add_messages_case; - ] end type 'b case = @@ -1026,17 +991,6 @@ module Encoding = struct @@ merge_objs Operation.shell_header_encoding (obj1 (req "contents" contents_list_encoding)) - - let internal_operation_encoding = - def "operation.alpha.internal_operation" - @@ conv - (fun (Internal_operation {source; operation; nonce}) -> - ((source, nonce), Manager operation)) - (fun ((source, nonce), Manager operation) -> - Internal_operation {source; operation; nonce}) - (merge_objs - (obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16)) - Manager_operations.encoding) end let encoding = Encoding.operation_encoding @@ -1049,8 +1003,6 @@ let protocol_data_encoding = Encoding.protocol_data_encoding let unsigned_operation_encoding = Encoding.unsigned_operation_encoding -let internal_operation_encoding = Encoding.internal_operation_encoding - let raw ({shell; protocol_data} : _ operation) = let proto = Data_encoding.Binary.to_bytes_exn diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 91ce0a4a4f3d..f6d7fb7f8755 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -278,12 +278,6 @@ and _ manager_operation = and counter = Z.t -type 'kind internal_operation = { - source : Contract_repr.contract; - operation : 'kind manager_operation; - nonce : int; -} - type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation @@ -306,9 +300,6 @@ type packed_operation = { val pack : 'kind operation -> packed_operation -type packed_internal_operation = - | Internal_operation : 'kind internal_operation -> packed_internal_operation - val manager_kind : 'kind manager_operation -> 'kind Kind.manager val encoding : packed_operation Data_encoding.t @@ -339,8 +330,6 @@ type error += Invalid_signature (* `Permanent *) val check_signature : Signature.Public_key.t -> Chain_id.t -> _ operation -> unit tzresult -val internal_operation_encoding : packed_internal_operation Data_encoding.t - type ('a, 'b) eq = Eq : ('a, 'a) eq val equal : 'a operation -> 'b operation -> ('a, 'b) eq option diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index a7f1176e58fa..71f8c1971a81 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1445,28 +1445,6 @@ let manager_kind : type kind. kind manager_operation -> kind Kind.manager = | Delegation _ -> Kind.Delegation_manager_kind | Tx_rollup_commit _ -> Kind.Tx_rollup_commit_manager_kind -let unty_internal_operation : - type kind. kind internal_operation -> kind Alpha_context.internal_operation - = - fun {source; operation; nonce} -> - let operation : kind Alpha_context.manager_operation = - match operation with - | Transaction {manager_transaction; parameters_ty = _; parameters = _} -> - Alpha_context.Transaction manager_transaction - | Origination {manager_origination; preorigination = _; parsed_script = _} -> - Alpha_context.Origination manager_origination - | Delegation delegate -> Alpha_context.Delegation delegate - | Tx_rollup_commit tx_rollup_commit -> - Alpha_context.Tx_rollup_commit tx_rollup_commit - in - Alpha_context.{source; operation; nonce} - -let unty_packed_internal_operation (Internal_operation operation) = - let operation = unty_internal_operation operation in - Alpha_context.Internal_operation operation - -let unty_operations = List.map unty_packed_internal_operation - let kinfo_of_kinstr : type a s b f. (a, s, b, f) kinstr -> (a, s) kinfo = fun i -> match i with diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index a368a0e20879..e343e6d8fba7 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1567,21 +1567,6 @@ type packed_manager_operation = val manager_kind : 'kind manager_operation -> 'kind Kind.manager -(** [unty_internal_operation iop] removes the typing information inside - [iop]. *) -val unty_internal_operation : - 'kind internal_operation -> 'kind Alpha_context.internal_operation - -(** [unty_packed_internal_operation piop] removes the typing information inside - [piop]. *) -val unty_packed_internal_operation : - packed_internal_operation -> Alpha_context.packed_internal_operation - -(** [unty_operations ops] removes the typing information inside each operation - of [ops]. *) -val unty_operations : - packed_internal_operation list -> Alpha_context.packed_internal_operation list - val kinfo_of_kinstr : ('a, 's, 'b, 'f) kinstr -> ('a, 's) kinfo type kinstr_rewritek = { -- GitLab From aa48a148f1d24d447cff4e3e57824f942c6dbe46 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Wed, 16 Feb 2022 11:34:05 +0100 Subject: [PATCH 49/63] Tests: update regression tests gas. --- ...SelfAddressTransfer::test_send_self_address.out | 4 ++-- ...des.TestContractOnchainOpcodes::test_source.out | 4 ++-- ...ontractOnchainOpcodes::test_transfer_tokens.out | 8 ++++---- ...ddApproveTransferRemove::test_add_liquidity.out | 14 +++++++------- ...pproveTransferRemove::test_remove_liquidity.out | 14 +++++++------- ...idity_baking.TestTrades::test_add_liquidity.out | 14 +++++++------- ...t_liquidity_baking.TestTrades::test_buy_tok.out | 12 ++++++------ ..._liquidity_baking.TestTrades::test_sell_tok.out | 12 ++++++------ 8 files changed, 41 insertions(+), 41 deletions(-) diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out index 2ff966fe8b77..fd114ecea713 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract.TestSelfAddressTransfer::test_send_self_address.out @@ -1,7 +1,7 @@ tests_alpha/test_contract.py::TestSelfAddressTransfer::test_send_self_address Node is bootstrapped. -Estimated gas: 5192.870 units (will add 100 for safety) +Estimated gas: 5192.330 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -37,6 +37,6 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 83 bytes - Consumed gas: 2059.158 + Consumed gas: 2058.618 Injected block at minimal timestamp diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out index bb009da93fb3..95bc90419535 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_source.out @@ -78,7 +78,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 4338.878 units (will add 100 for safety) +Estimated gas: 4338.998 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -113,7 +113,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: 0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c Storage size: 65 bytes - Consumed gas: 1212.540 + Consumed gas: 1212.660 Injected block at minimal timestamp "[CONTRACT_HASH]" diff --git a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out index 9e27ff8ce890..96b92d284e10 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_contract_onchain_opcodes.TestContractOnchainOpcodes::test_transfer_tokens.out @@ -143,7 +143,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 5177.041 units (will add 100 for safety) +Estimated gas: 5177.161 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -181,7 +181,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 38 bytes - Consumed gas: 2048.709 + Consumed gas: 2048.829 Balance updates: [CONTRACT_HASH] ... -ꜩ100 [CONTRACT_HASH] ... +ꜩ100 @@ -191,7 +191,7 @@ Injected block at minimal timestamp [CONTRACT_HASH] Node is bootstrapped. -Estimated gas: 4324.014 units (will add 100 for safety) +Estimated gas: 4324.134 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -229,7 +229,7 @@ This sequence of operations was run: This transaction was successfully applied Updated storage: Unit Storage size: 38 bytes - Consumed gas: 2048.709 + Consumed gas: 2048.829 Balance updates: [CONTRACT_HASH] ... -ꜩ100 [CONTRACT_HASH] ... +ꜩ100 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out index 5b38b45e78b4..7762c8f85ac3 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_add_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestAddApproveTransferRemove::test_add_liquidity Node is bootstrapped. -Estimated gas: 11824.095 units (will add 100 for safety) +Estimated gas: 9874.655 units (will add 100 for safety) Estimated storage: 141 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001548 + Fee to the baker: ꜩ0.001353 Expected counter: [EXPECTED_COUNTER] - Gas limit: 11925 + Gas limit: 9975 Storage limit: 161 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001548 - payload fees(the block proposer) ....... +ꜩ0.001548 + [CONTRACT_HASH] ... -ꜩ0.001353 + payload fees(the block proposer) ....... +ꜩ0.001353 Transaction: Amount: ꜩ9001 From: [CONTRACT_HASH] @@ -58,7 +58,7 @@ This sequence of operations was run: Set map(0)[0x01d496def47a3be89f5d54c6e6bb13cc6645d6e16600] to 721 Storage size: 2263 bytes Paid storage size diff: 68 bytes - Consumed gas: 4394.836 + Consumed gas: 3095.236 Balance updates: [CONTRACT_HASH] ... -ꜩ0.017 storage fees ........................... +ꜩ0.017 @@ -75,7 +75,7 @@ This sequence of operations was run: Set map(2)[0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78] to 72007 Storage size: 2048 bytes Paid storage size diff: 70 bytes - Consumed gas: 4516.613 + Consumed gas: 3866.773 Balance updates: [CONTRACT_HASH] ... -ꜩ0.0175 storage fees ........................... +ꜩ0.0175 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out index 9c736aaec8de..319005e5ca27 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestAddApproveTransferRemove::test_remove_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestAddApproveTransferRemove::test_remove_liquidity Node is bootstrapped. -Estimated gas: 10535.551 units (will add 100 for safety) +Estimated gas: 8586.111 units (will add 100 for safety) Estimated storage: 67 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001416 + Fee to the baker: ꜩ0.001221 Expected counter: [EXPECTED_COUNTER] - Gas limit: 10636 + Gas limit: 8687 Storage limit: 87 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001416 - payload fees(the block proposer) ....... +ꜩ0.001416 + [CONTRACT_HASH] ... -ꜩ0.001221 + payload fees(the block proposer) ....... +ꜩ0.001221 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -47,7 +47,7 @@ This sequence of operations was run: Updated big_maps: Unset map(2)[0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c] Storage size: 2048 bytes - Consumed gas: 2522.999 + Consumed gas: 1873.159 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -63,7 +63,7 @@ This sequence of operations was run: Set map(0)[0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c] to 10 Storage size: 2330 bytes Paid storage size diff: 67 bytes - Consumed gas: 3677.591 + Consumed gas: 2377.991 Balance updates: [CONTRACT_HASH] ... -ꜩ0.01675 storage fees ........................... +ꜩ0.01675 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out index f9805a93c93e..320386a0ccd3 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_add_liquidity.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_add_liquidity Node is bootstrapped. -Estimated gas: 11824.095 units (will add 100 for safety) +Estimated gas: 9874.655 units (will add 100 for safety) Estimated storage: 141 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001548 + Fee to the baker: ꜩ0.001353 Expected counter: [EXPECTED_COUNTER] - Gas limit: 11925 + Gas limit: 9975 Storage limit: 161 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001548 - payload fees(the block proposer) ....... +ꜩ0.001548 + [CONTRACT_HASH] ... -ꜩ0.001353 + payload fees(the block proposer) ....... +ꜩ0.001353 Transaction: Amount: ꜩ9001 From: [CONTRACT_HASH] @@ -58,7 +58,7 @@ This sequence of operations was run: Set map(0)[0x01d496def47a3be89f5d54c6e6bb13cc6645d6e16600] to 721 Storage size: 2263 bytes Paid storage size diff: 68 bytes - Consumed gas: 4394.836 + Consumed gas: 3095.236 Balance updates: [CONTRACT_HASH] ... -ꜩ0.017 storage fees ........................... +ꜩ0.017 @@ -75,7 +75,7 @@ This sequence of operations was run: Set map(2)[0x000002298c03ed7d454a101eb7022bc95f7e5f41ac78] to 72007 Storage size: 2048 bytes Paid storage size diff: 70 bytes - Consumed gas: 4516.613 + Consumed gas: 3866.773 Balance updates: [CONTRACT_HASH] ... -ꜩ0.0175 storage fees ........................... +ꜩ0.0175 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out index c272e7202084..a26a11c0d324 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_buy_tok.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_buy_tok Node is bootstrapped. -Estimated gas: 7500.823 units (will add 100 for safety) +Estimated gas: 6201.223 units (will add 100 for safety) Estimated storage: 326 bytes added (will add 20 for safety) Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001108 + Fee to the baker: ꜩ0.000978 Expected counter: [EXPECTED_COUNTER] - Gas limit: 7601 + Gas limit: 6302 Storage limit: 346 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001108 - payload fees(the block proposer) ....... +ꜩ0.001108 + [CONTRACT_HASH] ... -ꜩ0.000978 + payload fees(the block proposer) ....... +ꜩ0.000978 Transaction: Amount: ꜩ9001 From: [CONTRACT_HASH] @@ -56,7 +56,7 @@ This sequence of operations was run: Set map(0)[0x0000e7670f32038107a59a2b9cfefae36ea21f5aa63c] to 360 Storage size: 2331 bytes Paid storage size diff: 68 bytes - Consumed gas: 3677.595 + Consumed gas: 2377.995 Balance updates: [CONTRACT_HASH] ... -ꜩ0.017 storage fees ........................... +ꜩ0.017 diff --git a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out index dec69e87bf86..5ce937468948 100644 --- a/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out +++ b/tests_python/tests_alpha/_regtest_outputs/test_liquidity_baking.TestTrades::test_sell_tok.out @@ -1,7 +1,7 @@ tests_alpha/test_liquidity_baking.py::TestTrades::test_sell_tok Node is bootstrapped. -Estimated gas: 9819.219 units (will add 100 for safety) +Estimated gas: 8519.619 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[BLOCK_HASH]' @@ -12,13 +12,13 @@ and/or an external block explorer to make sure that it has been included. This sequence of operations was run: Manager signed operations: From: [CONTRACT_HASH] - Fee to the baker: ꜩ0.001337 + Fee to the baker: ꜩ0.001207 Expected counter: [EXPECTED_COUNTER] - Gas limit: 9920 + Gas limit: 8620 Storage limit: 0 bytes Balance updates: - [CONTRACT_HASH] ... -ꜩ0.001337 - payload fees(the block proposer) ....... +ꜩ0.001337 + [CONTRACT_HASH] ... -ꜩ0.001207 + payload fees(the block proposer) ....... +ꜩ0.001207 Transaction: Amount: ꜩ0 From: [CONTRACT_HASH] @@ -51,7 +51,7 @@ This sequence of operations was run: Unset map(0)[0x0000dac9f52543da1aed0bc1d6b46bf7c10db7014cd6] Set map(0)[0x01d496def47a3be89f5d54c6e6bb13cc6645d6e16600] to 461 Storage size: 2331 bytes - Consumed gas: 4574.872 + Consumed gas: 3275.272 Transaction: Amount: ꜩ3891.966034 From: [CONTRACT_HASH] -- GitLab From ae0cea4b9f949e44c020f85697d87f9e4a12ff07 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Thu, 17 Feb 2022 20:39:35 +0100 Subject: [PATCH 50/63] Tests: update a regression test gas. But this one looks suspicious: some hexadecimal values have changed in the output. --- ...Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" | 23 +++++++++---------- 1 file changed, 11 insertions(+), 12 deletions(-) diff --git "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" index 4b98d5ac09ec..d08a4da8f2af 100644 --- "a/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" +++ "b/tests_python/tests_alpha/_regtest_outputs/test_contract_opcodes.TestContractOpcodes::test_contract_input_output[create_contract.tz-None-Unit-(Some \"KT1Mjjcb6tmSsLm7Cb3.c3984fbc14.out" @@ -26,24 +26,23 @@ emitted operations [ None 50000 Unit ] - - location: 13 (remaining gas: 1039983.548 units remaining) - [ 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b + - location: 13 (remaining gas: 1039982.468 units remaining) + [ 0x30 "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm" ] - - location: 25 (remaining gas: 1039983.533 units remaining) + - location: 25 (remaining gas: 1039982.453 units remaining) [ "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm" ] - - location: 27 (remaining gas: 1039983.518 units remaining) + - location: 27 (remaining gas: 1039982.438 units remaining) [ (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 28 (remaining gas: 1039983.503 units remaining) + - location: 28 (remaining gas: 1039982.423 units remaining) [ {} (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 25 (remaining gas: 1039983.473 units remaining) - [ 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b + - location: 25 (remaining gas: 1039982.393 units remaining) + [ 0x30 {} (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 30 (remaining gas: 1039983.458 units remaining) - [ { 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b } + - location: 30 (remaining gas: 1039982.378 units remaining) + [ { 0x30 } (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm") ] - - location: 31 (remaining gas: 1039983.443 units remaining) - [ (Pair { 0x011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe600000002d08603000000001c02000000170500036c0501036c050202000000080317053d036d034200000002030b } - (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm")) ] + - location: 31 (remaining gas: 1039982.363 units remaining) + [ (Pair { 0x30 } (Some "KT1Mjjcb6tmSsLm7Cb3DSQszePjfchPM4Uxm")) ] -- GitLab From df9048b4abc8c4360703ece89e48fbf9af510fe1 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 21 Feb 2022 00:05:04 +0100 Subject: [PATCH 51/63] Proto/Michelson-Plugin-Client-Benchmark: format ocaml. --- .../lib_client/client_proto_context.ml | 7 +- .../lib_client/client_proto_programs.mli | 4 +- .../lib_client/michelson_v1_error_reporter.ml | 3 +- src/proto_alpha/lib_plugin/plugin.ml | 32 +++-- src/proto_alpha/lib_protocol/apply.ml | 116 +++++++----------- src/proto_alpha/lib_protocol/apply_results.ml | 12 +- .../lib_protocol/apply_results.mli | 1 + .../lib_protocol/operation_repr.ml | 7 +- .../lib_protocol/script_interpreter.ml | 27 ++-- .../lib_protocol/script_interpreter_defs.ml | 24 ++-- .../lib_protocol/script_ir_translator.ml | 28 +++-- .../lib_protocol/test/helpers/op.ml | 4 +- .../michelson/test_ticket_accounting.ml | 19 ++- .../michelson/test_ticket_operations_diff.ml | 112 ++++++++++++----- .../lib_protocol/ticket_operations_diff.ml | 37 +++--- 15 files changed, 239 insertions(+), 194 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 093d3c41d76a..e5bab8c5e1d3 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -357,12 +357,7 @@ let build_origination_operation ?fee ?gas_limit ?storage_limit ~initial_storage >>=? fun {Michelson_v1_parser.expanded = storage; _} -> let code = Script.lazy_expr code and storage = Script.lazy_expr storage in let origination = - Origination - { - delegate; - script = {code; storage}; - credit = balance; - } + Origination {delegate; script = {code; storage}; credit = balance} in return (Injection.prepare_manager_operation diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index c5020b05ee3e..41779bb3f090 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -73,7 +73,9 @@ val run : chain:Shell_services.chain -> block:Shell_services.block -> run_params -> - (Script.expr * Apply_results.packed_internal_operation_result list * Lazy_storage.diffs option) + (Script.expr + * Apply_results.packed_internal_operation_result list + * Lazy_storage.diffs option) tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 9ff59733e718..72f0077a7b3b 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -376,7 +376,8 @@ let report_errors ~details ~show_source ?parsed ppf errs = (parsed, hilights) ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest - | Environment.Ecoproto_error (Apply.Internal_operation_replay {nonce}) :: rest -> + | Environment.Ecoproto_error (Apply.Internal_operation_replay {nonce}) + :: rest -> Format.fprintf ppf "@[Internal operation replay attempt:@,%d@]" diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index f50e1650528b..a4663917ca33 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1462,7 +1462,11 @@ module View_helpers = struct match operations with | [ Script_typed_ir.Internal_operation - {operation = Transaction {manager_transaction = {destination; parameters; _}; _}; _}; + { + operation = + Transaction {manager_transaction = {destination; parameters; _}; _}; + _; + }; ] when Destination.equal destination (Contract callback) -> ok parameters @@ -1601,7 +1605,9 @@ module RPC = struct (storage, operations, lazy_storage_diff)) (obj3 (req "storage" Script.expr_encoding) - (req "operations" (list Apply_results.internal_operation_result_encoding)) + (req + "operations" + (list Apply_results.internal_operation_result_encoding)) (opt "lazy_storage_diff" Lazy_storage.encoding)) let trace_code_input_encoding = run_code_input_encoding @@ -1621,7 +1627,9 @@ module RPC = struct (storage, operations, trace, lazy_storage_diff)) (obj4 (req "storage" Script.expr_encoding) - (req "operations" (list Apply_results.internal_operation_result_encoding)) + (req + "operations" + (list Apply_results.internal_operation_result_encoding)) (req "trace" trace_encoding) (opt "lazy_storage_diff" Lazy_storage.encoding)) @@ -2245,7 +2253,10 @@ module RPC = struct lazy_storage_diff; _; }, - _ ) -> (storage, Apply_results.results_of_internal_operations operations, lazy_storage_diff)) ; + _ ) -> + ( storage, + Apply_results.results_of_internal_operations operations, + lazy_storage_diff )) ; Registration.register0 ~chunked:true S.trace_code @@ -2311,7 +2322,11 @@ module RPC = struct lazy_storage_diff; _; }, - trace ) -> (storage, Apply_results.results_of_internal_operations operations, trace, lazy_storage_diff)) ; + trace ) -> + ( storage, + Apply_results.results_of_internal_operations operations, + trace, + lazy_storage_diff )) ; Registration.register0 ~chunked:true S.run_view @@ -3037,12 +3052,7 @@ module RPC = struct ~storage_limit [ Manager - (Origination - { - delegate = delegatePubKey; - script; - credit = balance; - }); + (Origination {delegate = delegatePubKey; script; credit = balance}); ] let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 89ae8b65f204..0abac9e50dbb 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -832,29 +832,12 @@ let assert_sc_rollup_feature_enabled ctxt = let apply_delegation ctxt source delegate since = Delegate.set ctxt source delegate >|=? fun ctxt -> - ( ctxt, - Delegation_result - {consumed_gas = Gas.consumed ~since ~until:ctxt}, - [] ) + (ctxt, Delegation_result {consumed_gas = Gas.consumed ~since ~until:ctxt}, []) -let apply_transaction - ~consume_deserialization_gas - ctxt - typed_parameters - parameters - source - destination - amount - entrypoint - before_operation - payer - chain_id - mode - internal = - Script.force_decode_in_context - ~consume_deserialization_gas - ctxt - parameters +let apply_transaction ~consume_deserialization_gas ctxt typed_parameters + parameters source destination amount entrypoint before_operation payer + chain_id mode internal = + Script.force_decode_in_context ~consume_deserialization_gas ctxt parameters >>?= fun (parameter, ctxt) -> (match Contract.is_implicit destination with | None -> @@ -887,9 +870,7 @@ let apply_transaction | Prim (_, D_Unit, [], _) -> (* Allow [Unit] parameter to non-scripted contracts. *) ok ctxt - | _ -> - error - (Script_interpreter.Bad_contract_parameter destination) + | _ -> error (Script_interpreter.Bad_contract_parameter destination) ) >|? fun ctxt -> let result = @@ -930,9 +911,11 @@ let apply_transaction level; } in - let parameter = match typed_parameters with + let parameter = + match typed_parameters with | None -> Script_interpreter.Untyped_arg parameter - | Some (arg_ty, arg) -> Script_interpreter.Typed_arg (arg_ty, arg) in + | Some (arg_ty, arg) -> Script_interpreter.Typed_arg (arg_ty, arg) + in Script_interpreter.execute ctxt ~cached_script:(Some script_ir) @@ -944,17 +927,11 @@ let apply_transaction ~internal >>=? fun ( {ctxt; storage; lazy_storage_diff; operations}, (updated_cached_script, updated_size) ) -> - Contract.update_script_storage - ctxt - destination - storage - lazy_storage_diff + Contract.update_script_storage ctxt destination storage lazy_storage_diff >>=? fun ctxt -> Fees.record_paid_storage_space ctxt destination >>=? fun (ctxt, new_size, paid_storage_size_diff) -> - Contract.originated_from_current_nonce - ~since:before_operation - ~until:ctxt + Contract.originated_from_current_nonce ~since:before_operation ~until:ctxt >>=? fun originated_contracts -> Lwt.return ( Script_cache.update @@ -981,17 +958,8 @@ let apply_transaction in (ctxt, result, operations) ) -let apply_origination - consume_deserialization_gas - ctxt - parsed_script - script - internal - preoriginate - delegate - source - credit - before_operation = +let apply_origination consume_deserialization_gas ctxt parsed_script script + internal preoriginate delegate source credit before_operation = Script.force_decode_in_context ~consume_deserialization_gas ctxt @@ -1003,13 +971,14 @@ let apply_origination script.Script.code >>?= fun (unparsed_code, ctxt) -> (match parsed_script with - | None -> - Script_ir_translator.parse_script - ctxt - ~legacy:false - ~allow_forged_in_storage:internal - script - | Some parsed_script -> return (Script_ir_translator.Ex_script parsed_script, ctxt)) + | None -> + Script_ir_translator.parse_script + ctxt + ~legacy:false + ~allow_forged_in_storage:internal + script + | Some parsed_script -> + return (Script_ir_translator.Ex_script parsed_script, ctxt)) >>=? fun (Ex_script parsed_script, ctxt) -> let views_result = Script_ir_translator.typecheck_views @@ -1018,9 +987,7 @@ let apply_origination parsed_script.storage_type parsed_script.views in - trace - (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) - views_result + trace (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) views_result >>=? fun ctxt -> Script_ir_translator.collect_lazy_storage ctxt @@ -1053,8 +1020,8 @@ let apply_origination ~script:(script, lazy_storage_diff) >>=? fun ctxt -> (match delegate with - | None -> return ctxt - | Some delegate -> Delegate.init ctxt contract delegate) + | None -> return ctxt + | Some delegate -> Delegate.init ctxt contract delegate) >>=? fun ctxt -> Token.transfer ctxt (`Contract source) (`Contract contract) credit >>=? fun (ctxt, balance_updates) -> @@ -1077,8 +1044,8 @@ let apply_tx_rollup_commit ctxt source tx_rollup commitment before_operation = (* TODO: bonds https://gitlab.com/tezos/tezos/-/issues/2459 *) match Contract.is_implicit source with | None -> - fail Tx_rollup_commit_with_non_implicit_contract - (* This is only called with implicit contracts *) + fail Tx_rollup_commit_with_non_implicit_contract + (* This is only called with implicit contracts *) | Some key -> Tx_rollup_commitments.add_commitment ctxt tx_rollup key commitment >>=? fun ctxt -> @@ -1153,8 +1120,9 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt} : kind successful_manager_operation_result), [] ) - | External_mop (Transaction - {amount; parameters; destination = Contract destination; entrypoint}) -> + | External_mop + (Transaction + {amount; parameters; destination = Contract destination; entrypoint}) -> apply_transaction ~consume_deserialization_gas ctxt @@ -1205,7 +1173,13 @@ let apply_manager_operation_content : source credit before_operation - | Internal_mop (Origination {manager_origination = {delegate; script; credit}; preorigination; parsed_script}) -> + | Internal_mop + (Origination + { + manager_origination = {delegate; script; credit}; + preorigination; + parsed_script; + }) -> apply_origination consume_deserialization_gas ctxt @@ -1340,7 +1314,8 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = 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) :: rest -> ( + | Script_typed_ir.Internal_operation ({source; operation; nonce} as op) + :: rest -> ( (if internal_nonce_already_recorded ctxt nonce then fail (Internal_operation_replay {nonce}) else @@ -1358,13 +1333,15 @@ let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops = | Error errors -> let result = pack_operation_result - op (Failed (Script_typed_ir.manager_kind op.operation, errors)) + op + (Failed (Script_typed_ir.manager_kind op.operation, errors)) in let skipped = List.rev_map (fun (Script_typed_ir.Internal_operation op) -> pack_operation_result - op (Skipped (Script_typed_ir.manager_kind op.operation))) + op + (Skipped (Script_typed_ir.manager_kind op.operation))) rest in Lwt.return (Failure, List.rev (skipped @ result :: applied)) @@ -1647,9 +1624,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id | Applied smopr -> burn_storage_fees ctxt smopr ~storage_limit ~payer:source >>=? fun (ctxt, storage_limit, smopr) -> - let iopr = - Operation_result (op, Applied smopr) - in + let iopr = Operation_result (op, Applied smopr) in return (ctxt, storage_limit, iopr :: res) | _ -> return (ctxt, storage_limit, iopr :: res)) (ctxt, storage_limit, []) @@ -1908,8 +1883,7 @@ let mark_backtracked results = op.internal_operation_results; }, mark_contents_list rest ) - and mark_internal_operation_results (Operation_result (kind, result)) - = + and mark_internal_operation_results (Operation_result (kind, result)) = Operation_result (kind, mark_manager_operation_result result) and mark_manager_operation_result : type kind. kind manager_operation_result -> kind manager_operation_result diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 8755b248edaa..aaa24ff83282 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -90,7 +90,8 @@ let result_of_internal_operation (type kind) let results_of_internal_operations l = let f (Script_typed_ir.Internal_operation internal_op) = - Internal_operation_result (result_of_internal_operation internal_op) in + Internal_operation_result (result_of_internal_operation internal_op) + in List.map f l type successful_transaction_result = @@ -673,7 +674,9 @@ module Internal_result = struct tag : int; name : string; encoding : 'a Data_encoding.t; - select : packed_internal_operation_contents_result -> 'kind internal_operation_contents_result option; + select : + packed_internal_operation_contents_result -> + 'kind internal_operation_contents_result option; proj : 'kind internal_operation_contents_result -> 'a; inj : 'a -> 'kind internal_operation_contents_result; } @@ -737,7 +740,7 @@ module Internal_result = struct inj = (fun (credit, delegate, script, preorigination) -> Origination - {manager_origination = {credit; delegate; script}; preorigination}); + {manager_origination = {credit; delegate; script}; preorigination}); } let[@coq_axiom_with_reason "gadt"] delegation_case = @@ -802,8 +805,7 @@ let internal_operation_result_encoding : make Internal_result.tx_rollup_commit_case; ] -let operation_result_encoding : - packed_operation_result Data_encoding.t = +let operation_result_encoding : packed_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) = diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 46afa786686d..7b8e46a72a4f 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -227,6 +227,7 @@ and packed_successful_manager_operation_result = | Successful_manager_result : 'kind successful_manager_operation_result -> packed_successful_manager_operation_result + and packed_operation_result = | Operation_result : 'kind internal_operation_result * 'kind manager_operation_result diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 6e0dfdecadde..016d82444d71 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -462,12 +462,7 @@ module Encoding = struct (function Manager (Origination _ as op) -> Some op | _ -> None); proj = (function - | Origination - { - credit; - delegate; - script; - } -> + | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = (fun (credit, delegate, script) -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 4033709fbd53..262d6ef059d5 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1713,17 +1713,26 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal ctxt ) -> Gas_monad.run ctxt - (find_entrypoint_cstr ~error_details:Informative arg_type entrypoints entrypoint) + (find_entrypoint_cstr + ~error_details:Informative + arg_type + entrypoints + entrypoint) >>?= fun (r, ctxt) -> record_trace (Bad_contract_parameter step_constants.self) r >>?= fun (box, Ex_ty_cstr (entrypoint_ty, typed_box)) -> (match arg with - | Untyped_arg arg -> - let arg = Micheline.root arg in - trace - (Bad_contract_parameter step_constants.self) - (parse_data ctxt ~legacy:false ~allow_forged:internal arg_type (box arg)) - | Typed_arg (parsed_arg_ty, parsed_arg) -> + | Untyped_arg arg -> + let arg = Micheline.root arg in + trace + (Bad_contract_parameter step_constants.self) + (parse_data + ctxt + ~legacy:false + ~allow_forged:internal + arg_type + (box arg)) + | Typed_arg (parsed_arg_ty, parsed_arg) -> Gas_monad.run ctxt (Script_ir_translator.ty_eq @@ -1732,9 +1741,7 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal entrypoint_ty parsed_arg_ty) >>?= fun (res, ctxt) -> - res >>?= fun Eq -> - - return (typed_box parsed_arg, ctxt)) + res >>?= fun Eq -> return (typed_box parsed_arg, ctxt)) >>=? fun (arg, ctxt) -> Script_ir_translator.collect_lazy_storage ctxt arg_type arg >>?= fun (to_duplicate, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 672f6320bf49..de5471e62665 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -516,12 +516,12 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost p) >>?= fun ctxt -> let manager_transaction = - { - amount; - destination; - entrypoint; - parameters = Script.lazy_expr (Micheline.strip_locations p); - } + { + amount; + destination; + entrypoint; + parameters = Script.lazy_expr (Micheline.strip_locations p); + } in let operation = Transaction {manager_transaction; parameters_ty; parameters} @@ -590,12 +590,12 @@ let create_contract (ctxt, sc) gas storage_type param_type lambda code views let storage = strip_locations storage in Contract.fresh_contract_from_current_nonce ctxt >>?= fun (ctxt, contract) -> let manager_origination = - { - credit; - delegate; - script = - {code = Script.lazy_expr code; storage = Script.lazy_expr storage}; - } + { + credit; + delegate; + script = + {code = Script.lazy_expr code; storage = Script.lazy_expr storage}; + } in Script_ir_translator.code_size ctxt lambda views >>?= fun (ctxt, code_size) -> let parsed_script = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 2aa326ed14de..5f0ab7fb2043 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -480,7 +480,7 @@ let unparse_key_hash ~loc ctxt mode k = (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = - let Internal_operation iop = piop in + let (Internal_operation iop) = piop in let bytes = Bytes.of_string @@ string_of_int iop.nonce in Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> (Bytes (loc, bytes), ctxt) @@ -1845,17 +1845,24 @@ let find_entrypoint_cstr (type full error_trace) return ((fun e -> e), Ex_ty_cstr (ty, fun e -> e)) | (Union_t (tl, tr, _), {nested = Entrypoints_Union {left; right}; _}) -> ( Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function - | Ok (f, Ex_ty_cstr (t, f')) -> return ((fun e -> Prim (loc, D_Left, [f e], [])), Ex_ty_cstr (t, fun e -> L (f' e))) + | Ok (f, Ex_ty_cstr (t, f')) -> + return + ( (fun e -> Prim (loc, D_Left, [f e], [])), + Ex_ty_cstr (t, fun e -> L (f' e)) ) | Error () -> - let+ (f, Ex_ty_cstr (t, f')) = find_entrypoint tr right entrypoint in - ((fun e -> Prim (loc, D_Right, [f e], [])), Ex_ty_cstr (t, fun e -> R (f' e)))) + let+ (f, Ex_ty_cstr (t, f')) = + find_entrypoint tr right entrypoint + in + ( (fun e -> Prim (loc, D_Right, [f e], [])), + Ex_ty_cstr (t, fun e -> R (f' e)) )) | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in Gas_monad.bind_recover (find_entrypoint full entrypoints entrypoint) @@ function | Ok f_t -> return f_t | Error () -> - if Entrypoint.is_default entrypoint then return ((fun e -> e), Ex_ty_cstr (full, fun e -> e)) + if Entrypoint.is_default entrypoint then + return ((fun e -> e), Ex_ty_cstr (full, fun e -> e)) else Gas_monad.of_result @@ Error @@ -5283,8 +5290,7 @@ let code_size ctxt code views = This is safe, as we already pay gas proportional to [views_size] and [ir_size] during their typechecking. *) Gas.consume ctxt (Script_typed_ir_size_costs.nodes_cost ~nodes) - >>? fun ctxt -> - ok (ctxt, code_size) + >>? fun ctxt -> ok (ctxt, code_size) let parse_code : ?type_logger:type_logger -> @@ -5327,10 +5333,10 @@ let parse_code : code_field) >>=? fun (code, ctxt) -> Lwt.return - (code_size ctxt code views >>? fun (ctxt, code_size) -> - ok - ( Ex_code {code; arg_type; storage_type; views; entrypoints; code_size}, - ctxt )) + ( code_size ctxt code views >>? fun (ctxt, code_size) -> + ok + ( Ex_code {code; arg_type; storage_type; views; entrypoints; code_size}, + ctxt ) ) let parse_storage : ?type_logger:type_logger -> diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index ca1b539fdab0..7e3131a81e53 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -310,8 +310,8 @@ let originated_contract op = exception Impossible -let contract_origination ?counter ?delegate ~script - ?public_key ?credit ?fee ?gas_limit ?storage_limit ctxt source = +let contract_origination ?counter ?delegate ~script ?public_key ?credit ?fee + ?gas_limit ?storage_limit ctxt source = Context.Contract.manager ctxt source >>=? fun account -> let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in let default_credit = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 3dd97951048b..fca95f5e1473 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -342,12 +342,7 @@ let origination_operation ~ctxt ~src ~script ~orig_contract = operation = Origination { - manager_origination = - { - delegate = None; - script; - credit = Tez.one; - }; + manager_origination = {delegate = None; script; credit = Tez.one}; preorigination = orig_contract; parsed_script; }; @@ -385,15 +380,15 @@ let transfer_operation ctxt ~src ~destination ~arg_type ~arg = { manager_transaction = { - amount = Tez.zero; - parameters = - Script.lazy_expr @@ Micheline.strip_locations params_node; - entrypoint = Entrypoint.default; - destination = Destination.Contract destination; + amount = Tez.zero; + parameters = + Script.lazy_expr @@ Micheline.strip_locations params_node; + entrypoint = Entrypoint.default; + destination = Destination.Contract destination; }; parameters_ty = arg_type; parameters = arg; - }; + }; nonce = 1; }, ctxt ) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index 2aa14c048b46..264d1f579066 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -245,12 +245,7 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = operation = Origination { - manager_origination = - { - delegate = None; - script; - credit = Tez.one; - }; + manager_origination = {delegate = None; script; credit = Tez.one}; preorigination = orig_contract; parsed_script; }; @@ -261,7 +256,8 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = return (orig_contract, operation, incr) let delegation_operation ~src = - Script_typed_ir.Internal_operation {source = src; operation = Delegation None; nonce = 1} + Script_typed_ir.Internal_operation + {source = src; operation = Delegation None; nonce = 1} let originate block ~src ~baker ~script ~storage ~forges_tickets = let* (orig_contract, _script, block) = @@ -293,14 +289,14 @@ let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = { manager_transaction = { - amount = Tez.zero; - parameters = - Script.lazy_expr @@ Micheline.strip_locations params_node; - entrypoint = Entrypoint.default; - destination = Destination.Contract destination; + amount = Tez.zero; + parameters = + Script.lazy_expr @@ Micheline.strip_locations params_node; + entrypoint = Entrypoint.default; + destination = Destination.Contract destination; }; parameters_ty; - parameters + parameters; }; nonce = 1; }, @@ -350,11 +346,7 @@ let make_tickets (l : (Contract.t * string * int) list) = let test_non_ticket_operations () = let* (_baker, src, block) = init () in let* incr = Incremental.begin_construction block in - let operations = - [ - delegation_operation ~src; - ] - in + let operations = [delegation_operation ~src] in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr operations in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] @@ -371,7 +363,12 @@ let test_transfer_to_non_ticket_contract () = ~forges_tickets:false in let* (operation, incr) = - transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty:unit_t ~parameters:() + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty:unit_t + ~parameters:() in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] @@ -391,7 +388,12 @@ let test_transfer_empty_ticket_list () = list_ticket_string_ty >>??= fun parameters_ty -> make_tickets [] >>=?? fun parameters -> let* (operation, incr) = - transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty ~parameters + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt ~loc:__LOC__ ticket_diffs ~expected:[] @@ -412,7 +414,12 @@ let test_transfer_one_ticket () = list_ticket_string_ty >>??= fun parameters_ty -> make_tickets [(ticketer, "white", 1)] >>=?? fun parameters -> let* (operation, incr) = - transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty ~parameters + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs @@ -442,9 +449,21 @@ let test_transfer_multiple_tickets () = ~forges_tickets:false in list_ticket_string_ty >>??= fun parameters_ty -> - make_tickets [(ticketer, "red", 1) ; (ticketer, "blue", 2) ; (ticketer, "green", 3) ; (ticketer, "red", 4)] >>=?? fun parameters -> + make_tickets + [ + (ticketer, "red", 1); + (ticketer, "blue", 2); + (ticketer, "green", 3); + (ticketer, "red", 4); + ] + >>=?? fun parameters -> let* (operation, incr) = - transfer_operation ~incr ~src ~destination:orig_contract ~parameters_ty ~parameters + transfer_operation + ~incr + ~src + ~destination:orig_contract + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs @@ -475,7 +494,19 @@ let test_transfer_different_tickets () = let* (baker, src, block) = init () in let* (ticketer1, ticketer2) = two_ticketers block in list_ticket_string_ty >>??= fun parameters_ty -> - make_tickets [(ticketer1, "red", 1) ; (ticketer1, "green", 1) ; (ticketer1, "blue", 1) ; (ticketer2, "red", 1) ; (ticketer2, "green", 1) ; (ticketer2, "blue", 1) ; (ticketer1, "red", 1) ; (ticketer1, "green", 1) ; (ticketer1, "blue", 1)] >>=?? fun parameters -> + make_tickets + [ + (ticketer1, "red", 1); + (ticketer1, "green", 1); + (ticketer1, "blue", 1); + (ticketer2, "red", 1); + (ticketer2, "green", 1); + (ticketer2, "blue", 1); + (ticketer1, "red", 1); + (ticketer1, "green", 1); + (ticketer1, "blue", 1); + ] + >>=?? fun parameters -> let* (destination, incr) = originate block @@ -485,7 +516,9 @@ let test_transfer_different_tickets () = ~storage:"{}" ~forges_tickets:false in - let* (operation, incr) = transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters in + let* (operation, incr) = + transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters + in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation] in assert_equal_ticket_token_diffs ctxt @@ -530,7 +563,9 @@ let test_transfer_to_two_contracts_with_different_tickets () = let* (baker, src, block) = init () in let* ticketer = one_ticketer block in list_ticket_string_ty >>??= fun parameters_ty -> - make_tickets [(ticketer, "red", 1) ; (ticketer, "green", 1) ; (ticketer, "blue", 1)] >>=?? fun parameters -> + make_tickets + [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] + >>=?? fun parameters -> let* (destination1, incr) = originate block @@ -541,7 +576,12 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~forges_tickets:false in let* (operation1, incr) = - transfer_operation ~incr ~src ~destination:destination1 ~parameters_ty ~parameters + transfer_operation + ~incr + ~src + ~destination:destination1 + ~parameters_ty + ~parameters in let* block = Incremental.finalize_block incr in let* (destination2, incr) = @@ -554,7 +594,12 @@ let test_transfer_to_two_contracts_with_different_tickets () = ~forges_tickets:false in let* (operation2, incr) = - transfer_operation ~incr ~src ~destination:destination2 ~parameters_ty ~parameters + transfer_operation + ~incr + ~src + ~destination:destination2 + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation1; operation2] @@ -860,9 +905,16 @@ let test_originate_and_transfer () = ~forges_tickets:false in list_ticket_string_ty >>??= fun parameters_ty -> - make_tickets [(ticketer, "red", 1) ; (ticketer, "green", 1) ; (ticketer, "blue", 1)] >>=?? fun parameters -> + make_tickets + [(ticketer, "red", 1); (ticketer, "green", 1); (ticketer, "blue", 1)] + >>=?? fun parameters -> let* (operation2, incr) = - transfer_operation ~incr ~src ~destination:destination2 ~parameters_ty ~parameters + transfer_operation + ~incr + ~src + ~destination:destination2 + ~parameters_ty + ~parameters in let* (ticket_diffs, ctxt) = ticket_diffs_of_operations incr [operation1; operation2] diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 5f0fa21b68c5..b3479784f0f0 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -145,16 +145,17 @@ let tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters = (** Extract tickets of an origination operation by scanning the storage. *) let tickets_of_origination ctxt ~preorigination script = - (* Extract any tickets from the storage. Note that if the type of the - contract storage does not contain tickets, storage is not scanned. *) - Ticket_scanner.type_has_tickets ctxt script.Script_typed_ir.storage_type - >>?= fun (has_tickets, ctxt) -> - Ticket_scanner.tickets_of_value - ctxt - ~include_lazy:true - has_tickets - script.Script_typed_ir.storage - >|=? fun (tickets, ctxt) -> (Some {tickets; destination = preorigination}, ctxt) + (* Extract any tickets from the storage. Note that if the type of the + contract storage does not contain tickets, storage is not scanned. *) + Ticket_scanner.type_has_tickets ctxt script.Script_typed_ir.storage_type + >>?= fun (has_tickets, ctxt) -> + Ticket_scanner.tickets_of_value + ctxt + ~include_lazy:true + has_tickets + script.Script_typed_ir.storage + >|=? fun (tickets, ctxt) -> + (Some {tickets; destination = preorigination}, ctxt) (* TODO: #2352 Extend operations scanning to support rollup-operations once ready. @@ -166,12 +167,16 @@ let tickets_of_operation ctxt match operation with | Transaction { - manager_transaction = { - amount = _; - parameters = _; - entrypoint = _; - destination = Destination.Contract destination; - }; parameters_ty; parameters} -> + manager_transaction = + { + amount = _; + parameters = _; + entrypoint = _; + destination = Destination.Contract destination; + }; + parameters_ty; + parameters; + } -> tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters | Origination {manager_origination = _; preorigination; parsed_script} -> tickets_of_origination ctxt ~preorigination parsed_script -- GitLab From e16555a5bfe19cbd3ad02005f7ced3cf7129c49d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 21 Feb 2022 14:18:08 +0000 Subject: [PATCH 52/63] Script_typed_ir_size.value_size.Operation_t comment to fixup. --- src/proto_alpha/lib_protocol/script_typed_ir_size.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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 ff52caec2e7d..497757526823 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -307,8 +307,9 @@ let rec value_size : | Sapling_transaction_t _ -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x) - (* Operations are somewhat special values that can't be pushed on the stack - for instance. Requesting the size of an operation should not happen. *) + (* 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 _ -> .) -- GitLab From 8220f39442ece596cba40970f03853e1992e2b87 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 14:52:46 +0100 Subject: [PATCH 53/63] Proto/Michelson: find_entrypoint works at Michelson level. By renaming find_entrypoint_cstr to find_entrypoint, dropping the first returned value (the reconstruction at Micheline level), and removing find_entrypoint. --- .../lib_protocol/contract_services.ml | 2 +- .../lib_protocol/script_interpreter.ml | 18 +++------ .../lib_protocol/script_ir_translator.ml | 38 ++++++------------- .../lib_protocol/script_ir_translator.mli | 9 +---- 4 files changed, 18 insertions(+), 49 deletions(-) diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 2cb975ed4e87..7d5cd4b2cde6 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -377,7 +377,7 @@ let[@coq_axiom_with_reason "gadt"] register () = entrypoint >>? fun (r, ctxt) -> r |> function - | Ok (_f, Ex_ty ty) -> + | Ok (Ex_ty_cstr (ty, _)) -> unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _) -> Some (Micheline.strip_locations ty_node) | Error _ -> Result.return_none )) ; diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 262d6ef059d5..cc880affa35e 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1713,25 +1713,17 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal ctxt ) -> Gas_monad.run ctxt - (find_entrypoint_cstr - ~error_details:Informative - arg_type - entrypoints - entrypoint) + (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) >>?= fun (r, ctxt) -> record_trace (Bad_contract_parameter step_constants.self) r - >>?= fun (box, Ex_ty_cstr (entrypoint_ty, typed_box)) -> + >>?= fun (Ex_ty_cstr (entrypoint_ty, box)) -> (match arg with | Untyped_arg arg -> let arg = Micheline.root arg in trace (Bad_contract_parameter step_constants.self) - (parse_data - ctxt - ~legacy:false - ~allow_forged:internal - arg_type - (box arg)) + (parse_data ctxt ~legacy:false ~allow_forged:internal entrypoint_ty arg) + >>=? fun (parsed_arg, ctxt) -> return (box parsed_arg, ctxt) | Typed_arg (parsed_arg_ty, parsed_arg) -> Gas_monad.run ctxt @@ -1741,7 +1733,7 @@ let execute logger ctxt mode step_constants ~entrypoint ~internal entrypoint_ty parsed_arg_ty) >>?= fun (res, ctxt) -> - res >>?= fun Eq -> return (typed_box parsed_arg, ctxt)) + res >>?= fun Eq -> return (box parsed_arg, ctxt)) >>=? fun (arg, ctxt) -> Script_ir_translator.collect_lazy_storage ctxt arg_type arg >>?= fun (to_duplicate, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 5f0ab7fb2043..0cbbdcc48c69 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1826,35 +1826,26 @@ type 'before dup_n_proof_argument = type 'a ex_ty_cstr = Ex_ty_cstr : 'b ty * ('b -> 'a) -> 'a ex_ty_cstr -let find_entrypoint_cstr (type full error_trace) +let find_entrypoint (type full error_trace) ~(error_details : error_trace error_details) (full : full ty) (entrypoints : full entrypoints) entrypoint : - ((Script.node -> Script.node) * full ex_ty_cstr, error_trace) Gas_monad.t = + (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let loc = Micheline.dummy_location in let rec find_entrypoint : type t. - t ty -> - t entrypoints -> - Entrypoint.t -> - ((Script.node -> Script.node) * t ex_ty_cstr, unit) Gas_monad.t = + t ty -> t entrypoints -> Entrypoint.t -> (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 | (_, {name = Some name; _}) when Entrypoint.(name = entrypoint) -> - return ((fun e -> e), Ex_ty_cstr (ty, fun e -> e)) + return (Ex_ty_cstr (ty, fun e -> e)) | (Union_t (tl, tr, _), {nested = Entrypoints_Union {left; right}; _}) -> ( Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function - | Ok (f, Ex_ty_cstr (t, f')) -> - return - ( (fun e -> Prim (loc, D_Left, [f e], [])), - Ex_ty_cstr (t, fun e -> L (f' e)) ) + | Ok (Ex_ty_cstr (t, f')) -> return (Ex_ty_cstr (t, fun e -> L (f' e))) | Error () -> - let+ (f, Ex_ty_cstr (t, f')) = - find_entrypoint tr right entrypoint - in - ( (fun e -> Prim (loc, D_Right, [f e], [])), - Ex_ty_cstr (t, fun e -> R (f' e)) )) + let+ (Ex_ty_cstr (t, f')) = find_entrypoint tr right entrypoint in + Ex_ty_cstr (t, fun e -> R (f' e))) | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in Gas_monad.bind_recover (find_entrypoint full entrypoints entrypoint) @@ -1862,7 +1853,7 @@ let find_entrypoint_cstr (type full error_trace) | Ok f_t -> return f_t | Error () -> if Entrypoint.is_default entrypoint then - return ((fun e -> e), Ex_ty_cstr (full, fun e -> e)) + return (Ex_ty_cstr (full, fun e -> e)) else Gas_monad.of_result @@ Error @@ -1870,20 +1861,13 @@ let find_entrypoint_cstr (type full error_trace) | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) -let find_entrypoint ~error_details full entrypoints entrypoint = - let open Gas_monad.Syntax in - let+ (f, Ex_ty_cstr (t, _)) = - find_entrypoint_cstr ~error_details full entrypoints entrypoint - in - (f, Ex_ty t) - let find_entrypoint_for_type (type full exp error_trace) ~error_details ~(full : full ty) ~(expected : exp ty) entrypoints entrypoint loc : (Entrypoint.t * exp ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in let* res = find_entrypoint ~error_details full entrypoints entrypoint in match res with - | (_, Ex_ty ty) -> ( + | Ex_ty_cstr (ty, _) -> ( match entrypoints.name with | Some e when Entrypoint.is_root e && Entrypoint.is_default entrypoint -> Gas_monad.bind_recover @@ -4623,7 +4607,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : entrypoints entrypoint >>? fun (r, ctxt) -> - r >>? fun (_, Ex_ty param_type) -> + r >>? fun (Ex_ty_cstr (param_type, _)) -> contract_t loc param_type >>? fun res_ty -> let instr = { diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index d0bc076e648f..4c7f3b7ff6fc 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -417,19 +417,12 @@ val parse_contract_for_script : type 'a ex_ty_cstr = | Ex_ty_cstr : 'b Script_typed_ir.ty * ('b -> 'a) -> 'a ex_ty_cstr -val find_entrypoint_cstr : - error_details:'error_trace error_details -> - 't Script_typed_ir.ty -> - 't Script_typed_ir.entrypoints -> - Entrypoint.t -> - ((Script.node -> Script.node) * 't ex_ty_cstr, 'error_trace) Gas_monad.t - val find_entrypoint : error_details:'error_trace error_details -> 't Script_typed_ir.ty -> 't Script_typed_ir.entrypoints -> Entrypoint.t -> - ((Script.node -> Script.node) * ex_ty, 'error_trace) Gas_monad.t + ('t ex_ty_cstr, 'error_trace) Gas_monad.t val list_entrypoints : context -> -- GitLab From 98b554552bbe95e1ec1295c4a0c0e0ef4e9106c8 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 15:00:02 +0100 Subject: [PATCH 54/63] Proto/Plugin: adapt to find_entrypoint's interface change. --- src/proto_alpha/lib_plugin/plugin.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index a4663917ca33..ffd146bbff47 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2185,7 +2185,7 @@ module RPC = struct entrypoints entrypoint >>? fun (r, ctxt) -> - r >>? fun (_f, Ex_ty ty) -> + r >>? fun (Ex_ty_cstr (ty, _)) -> unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _) -> Micheline.strip_locations ty_node ) in -- GitLab From a3a612f532ea0f1b82d36996d576d8beb4ef49ef Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 15:23:42 +0100 Subject: [PATCH 55/63] Proto/Michelson: apply_transaction has a single execution parameter. --- src/proto_alpha/lib_protocol/apply.ml | 42 +++++++++++++++------------ 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 0abac9e50dbb..41df39e02e2c 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -834,11 +834,8 @@ let apply_delegation ctxt source delegate since = Delegate.set ctxt source delegate >|=? fun ctxt -> (ctxt, Delegation_result {consumed_gas = Gas.consumed ~since ~until:ctxt}, []) -let apply_transaction ~consume_deserialization_gas ctxt typed_parameters - parameters source destination amount entrypoint before_operation payer - chain_id mode internal = - Script.force_decode_in_context ~consume_deserialization_gas ctxt parameters - >>?= fun (parameter, ctxt) -> +let apply_transaction ctxt parameter source destination amount entrypoint + before_operation payer chain_id mode internal = (match Contract.is_implicit destination with | None -> (if Tez.(amount = zero) then @@ -866,10 +863,18 @@ let apply_transaction ~consume_deserialization_gas ctxt typed_parameters ( ( (if Entrypoint.is_default entrypoint then Result.return_unit else error (Script_tc_errors.No_such_entrypoint entrypoint)) >>? fun () -> - match Micheline.root parameter with - | Prim (_, D_Unit, [], _) -> + match parameter with + | Script_interpreter.Typed_arg (Unit_t, _) -> (* Allow [Unit] parameter to non-scripted contracts. *) ok ctxt + | Script_interpreter.Untyped_arg parameter -> ( + match Micheline.root parameter with + | Prim (_, D_Unit, [], _) -> + (* Allow [Unit] parameter to non-scripted contracts. *) + ok ctxt + | _ -> + error + (Script_interpreter.Bad_contract_parameter destination)) | _ -> error (Script_interpreter.Bad_contract_parameter destination) ) >|? fun ctxt -> @@ -911,11 +916,6 @@ let apply_transaction ~consume_deserialization_gas ctxt typed_parameters level; } in - let parameter = - match typed_parameters with - | None -> Script_interpreter.Untyped_arg parameter - | Some (arg_ty, arg) -> Script_interpreter.Typed_arg (arg_ty, arg) - in Script_interpreter.execute ctxt ~cached_script:(Some script_ir) @@ -1123,11 +1123,14 @@ let apply_manager_operation_content : | External_mop (Transaction {amount; parameters; destination = Contract destination; entrypoint}) -> - apply_transaction + Script.force_decode_in_context ~consume_deserialization_gas ctxt - None parameters + >>?= fun (parameter, ctxt) -> + apply_transaction + ctxt + (Script_interpreter.Untyped_arg parameter) source destination amount @@ -1140,14 +1143,17 @@ let apply_manager_operation_content : | Internal_mop (Transaction {manager_transaction; parameters_ty; parameters = typed_parameters}) -> - let {amount; parameters; destination = Contract destination; entrypoint} = + let { + amount; + parameters = _; + destination = Contract destination; + entrypoint; + } = manager_transaction in apply_transaction - ~consume_deserialization_gas ctxt - (Some (parameters_ty, typed_parameters)) - parameters + (Script_interpreter.Typed_arg (parameters_ty, typed_parameters)) source destination amount -- GitLab From 612bc59f14755ee652e2a53ba81f4862686a53d5 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 16:17:54 +0100 Subject: [PATCH 56/63] Proto/Michelson: labelled parameters for apply_transaction. --- src/proto_alpha/lib_protocol/apply.ml | 28 +++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 41df39e02e2c..29c3acb720d2 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -834,8 +834,8 @@ let apply_delegation ctxt source delegate since = Delegate.set ctxt source delegate >|=? fun ctxt -> (ctxt, Delegation_result {consumed_gas = Gas.consumed ~since ~until:ctxt}, []) -let apply_transaction ctxt parameter source destination amount entrypoint - before_operation payer chain_id mode internal = +let apply_transaction ~ctxt parameter ~source ~destination amount entrypoint + ~before_operation ~payer chain_id mode ~internal = (match Contract.is_implicit destination with | None -> (if Tez.(amount = zero) then @@ -1129,17 +1129,17 @@ let apply_manager_operation_content : parameters >>?= fun (parameter, ctxt) -> apply_transaction - ctxt + ~ctxt (Script_interpreter.Untyped_arg parameter) - source - destination + ~source + ~destination amount entrypoint - before_operation - payer + ~before_operation + ~payer chain_id mode - internal + ~internal | Internal_mop (Transaction {manager_transaction; parameters_ty; parameters = typed_parameters}) -> @@ -1152,17 +1152,17 @@ let apply_manager_operation_content : manager_transaction in apply_transaction - ctxt + ~ctxt (Script_interpreter.Typed_arg (parameters_ty, typed_parameters)) - source - destination + ~source + ~destination amount entrypoint - before_operation - payer + ~before_operation + ~payer chain_id mode - internal + ~internal | External_mop (Origination {delegate; script; credit}) -> (* The preoriginate parameter is only used to early return the address of an originated contract in Michelson. It cannot come from the -- GitLab From b55179f54811cc9a98f2d076633c7ce8ca693db6 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 16:22:51 +0100 Subject: [PATCH 57/63] Proto/Michelson: labelled parameters for apply_origination. --- src/proto_alpha/lib_protocol/apply.ml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 29c3acb720d2..35c5b59b9ce0 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -958,8 +958,8 @@ let apply_transaction ~ctxt parameter ~source ~destination amount entrypoint in (ctxt, result, operations) ) -let apply_origination consume_deserialization_gas ctxt parsed_script script - internal preoriginate delegate source credit before_operation = +let apply_origination consume_deserialization_gas ~ctxt parsed_script script + ~internal preoriginate ~delegate ~source credit ~before_operation = Script.force_decode_in_context ~consume_deserialization_gas ctxt @@ -1170,15 +1170,15 @@ let apply_manager_operation_content : let preoriginate ctxt = Contract.fresh_contract_from_current_nonce ctxt in apply_origination consume_deserialization_gas - ctxt + ~ctxt None script - internal + ~internal preoriginate - delegate - source + ~delegate + ~source credit - before_operation + ~before_operation | Internal_mop (Origination { @@ -1188,15 +1188,15 @@ let apply_manager_operation_content : }) -> apply_origination consume_deserialization_gas - ctxt + ~ctxt (Some parsed_script) script - internal + ~internal (fun ctxt -> ok (ctxt, preorigination)) - delegate - source + ~delegate + ~source credit - before_operation + ~before_operation | External_mop (Delegation delegate) -> apply_delegation ctxt source delegate before_operation | Internal_mop (Delegation delegate) -> -- GitLab From 84a371241a39feefa95f0114aa4f9b471c9ee10b Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 16:35:35 +0100 Subject: [PATCH 58/63] Proto/Michelson: rename manager_transaction to transaction. Does not compile. --- src/proto_alpha/lib_protocol/alpha_context.mli | 4 ++-- src/proto_alpha/lib_protocol/apply.ml | 6 +++--- src/proto_alpha/lib_protocol/apply_results.ml | 5 ++--- src/proto_alpha/lib_protocol/apply_results.mli | 2 +- src/proto_alpha/lib_protocol/operation_repr.ml | 4 ++-- src/proto_alpha/lib_protocol/operation_repr.mli | 4 ++-- src/proto_alpha/lib_protocol/script_interpreter_defs.ml | 6 ++---- src/proto_alpha/lib_protocol/script_typed_ir.ml | 2 +- src/proto_alpha/lib_protocol/script_typed_ir.mli | 2 +- .../test/integration/michelson/test_ticket_accounting.ml | 2 +- .../integration/michelson/test_ticket_operations_diff.ml | 2 +- src/proto_alpha/lib_protocol/ticket_operations_diff.ml | 2 +- 12 files changed, 19 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index a25e6a131dd5..dc321975fc0c 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2259,7 +2259,7 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit -type manager_transaction = { +type transaction = { amount : Tez.tez; parameters : Script.lazy_expr; entrypoint : Entrypoint.t; @@ -2347,7 +2347,7 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : manager_transaction -> Kind.transaction manager_operation + | Transaction : transaction -> Kind.transaction manager_operation | Origination : manager_origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 35c5b59b9ce0..473372117663 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1141,15 +1141,15 @@ let apply_manager_operation_content : mode ~internal | Internal_mop - (Transaction - {manager_transaction; parameters_ty; parameters = typed_parameters}) -> + (Transaction {transaction; parameters_ty; parameters = typed_parameters}) + -> let { amount; parameters = _; destination = Contract destination; entrypoint; } = - manager_transaction + transaction in apply_transaction ~ctxt diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index aaa24ff83282..ff4dd88c344f 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -48,7 +48,7 @@ let trace_encoding = make_trace_encoding error_encoding type 'kind internal_operation_contents_result = | Transaction : - Alpha_context.manager_transaction + Alpha_context.transaction -> Kind.transaction internal_operation_contents_result | Origination : { manager_origination : Alpha_context.manager_origination; @@ -78,8 +78,7 @@ let result_of_internal_operation (type kind) kind internal_operation_result = let operation : kind internal_operation_contents_result = match operation with - | Script_typed_ir.Transaction {manager_transaction; _} -> - Transaction manager_transaction + | Script_typed_ir.Transaction {transaction; _} -> Transaction transaction | Script_typed_ir.Origination {manager_origination; preorigination; _} -> Origination {manager_origination; preorigination} | Script_typed_ir.Delegation delegate -> Delegation delegate diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 7b8e46a72a4f..49aacf6a347d 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -35,7 +35,7 @@ open Alpha_context type 'kind internal_operation_contents_result = | Transaction : - Alpha_context.manager_transaction + Alpha_context.transaction -> Kind.transaction internal_operation_contents_result | Origination : { manager_origination : Alpha_context.manager_origination; diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 016d82444d71..a2d7724798b4 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -176,7 +176,7 @@ type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} let raw_encoding = Operation.encoding -type manager_transaction = { +type transaction = { amount : Tez_repr.tez; parameters : Script_repr.lazy_expr; entrypoint : Entrypoint_repr.t; @@ -264,7 +264,7 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : manager_transaction -> Kind.transaction manager_operation + | Transaction : transaction -> Kind.transaction manager_operation | Origination : manager_origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index f6d7fb7f8755..4d464e83da6f 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -155,7 +155,7 @@ type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} val raw_encoding : raw Data_encoding.t -type manager_transaction = { +type transaction = { amount : Tez_repr.tez; parameters : Script_repr.lazy_expr; entrypoint : Entrypoint_repr.t; @@ -243,7 +243,7 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation - | Transaction : manager_transaction -> Kind.transaction manager_operation + | Transaction : transaction -> Kind.transaction manager_operation | Origination : manager_origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index de5471e62665..6b5a55a95dd8 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -515,7 +515,7 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = let parameters = p in unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) -> Gas.consume ctxt (Script.strip_locations_cost p) >>?= fun ctxt -> - let manager_transaction = + let transaction = { amount; destination; @@ -523,9 +523,7 @@ let transfer (ctxt, sc) gas amount tp p destination entrypoint = parameters = Script.lazy_expr (Micheline.strip_locations p); } in - let operation = - Transaction {manager_transaction; parameters_ty; parameters} - in + let operation = Transaction {transaction; parameters_ty; parameters} in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let iop = {source = sc.self; operation; nonce} in let res = {piop = Internal_operation iop; lazy_storage_diff} in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 71f8c1971a81..2fd21f77d2fe 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1417,7 +1417,7 @@ and 'kind internal_operation = { and 'kind manager_operation = | Transaction : { - manager_transaction : Alpha_context.manager_transaction; + transaction : Alpha_context.transaction; parameters_ty : 'arg ty; parameters : 'arg; } diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index e343e6d8fba7..2d91cf775521 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1544,7 +1544,7 @@ and 'kind internal_operation = { and 'kind manager_operation = | Transaction : { - manager_transaction : Alpha_context.manager_transaction; + transaction : Alpha_context.transaction; parameters_ty : 'arg ty; parameters : 'arg; } diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index fca95f5e1473..e055ab3045a9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -378,7 +378,7 @@ let transfer_operation ctxt ~src ~destination ~arg_type ~arg = operation = Transaction { - manager_transaction = + transaction = { amount = Tez.zero; parameters = diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index 264d1f579066..76c8106fdf40 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -287,7 +287,7 @@ let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = operation = Transaction { - manager_transaction = + transaction = { amount = Tez.zero; parameters = diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index b3479784f0f0..873a448f9e7d 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -167,7 +167,7 @@ let tickets_of_operation ctxt match operation with | Transaction { - manager_transaction = + transaction = { amount = _; parameters = _; -- GitLab From 4804d5a5ef940d43234f2e67bc8b080d8f04bd14 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 16:37:00 +0100 Subject: [PATCH 59/63] Proto/Plugin: rename manager_transaction to transaction. --- src/proto_alpha/lib_plugin/plugin.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index ffd146bbff47..051063685ee9 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1463,8 +1463,7 @@ module View_helpers = struct | [ Script_typed_ir.Internal_operation { - operation = - Transaction {manager_transaction = {destination; parameters; _}; _}; + operation = Transaction {transaction = {destination; parameters; _}; _}; _; }; ] -- GitLab From 7b5ffea08e48f2ff89c0b34223944c2faa48cd98 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 16:48:00 +0100 Subject: [PATCH 60/63] Proto/Client: rename manager_transaction to transaction. --- src/proto_alpha/lib_client/operation_result.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 55ad06e410db..fb5a2cf29d98 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -323,8 +323,7 @@ let manager_operation (type kind) (operation : kind internal_operation_contents_result) : kind manager_operation = match operation with - | Transaction manager_transaction -> - Alpha_context.Transaction manager_transaction + | Transaction transaction -> Alpha_context.Transaction transaction | Origination {manager_origination; preorigination = _} -> Alpha_context.Origination manager_origination | Delegation delegate -> Alpha_context.Delegation delegate -- GitLab From 7c74504086b2608790488711c8cb2b81a485caa9 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 16:40:52 +0100 Subject: [PATCH 61/63] Proto/Michelson: rename manager_origination to origination. Does not compile. --- src/proto_alpha/lib_protocol/alpha_context.mli | 4 ++-- src/proto_alpha/lib_protocol/apply.ml | 2 +- src/proto_alpha/lib_protocol/apply_results.ml | 11 +++++------ src/proto_alpha/lib_protocol/apply_results.mli | 2 +- src/proto_alpha/lib_protocol/operation_repr.ml | 4 ++-- src/proto_alpha/lib_protocol/operation_repr.mli | 4 ++-- .../lib_protocol/script_interpreter_defs.ml | 4 ++-- src/proto_alpha/lib_protocol/script_typed_ir.ml | 2 +- src/proto_alpha/lib_protocol/script_typed_ir.mli | 2 +- .../integration/michelson/test_ticket_accounting.ml | 2 +- .../michelson/test_ticket_operations_diff.ml | 2 +- .../lib_protocol/ticket_operations_diff.ml | 2 +- 12 files changed, 20 insertions(+), 21 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index dc321975fc0c..832978faa95d 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2266,7 +2266,7 @@ type transaction = { destination : Destination.t; } -type manager_origination = { +type origination = { delegate : Signature.Public_key_hash.t option; script : Script.t; credit : Tez.tez; @@ -2348,7 +2348,7 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : transaction -> Kind.transaction manager_operation - | Origination : manager_origination -> Kind.origination manager_operation + | Origination : origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 473372117663..233c3d8dc7e2 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1182,7 +1182,7 @@ let apply_manager_operation_content : | Internal_mop (Origination { - manager_origination = {delegate; script; credit}; + origination = {delegate; script; credit}; preorigination; parsed_script; }) -> diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index ff4dd88c344f..27d479640d6c 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -51,7 +51,7 @@ type 'kind internal_operation_contents_result = Alpha_context.transaction -> Kind.transaction internal_operation_contents_result | Origination : { - manager_origination : Alpha_context.manager_origination; + origination : Alpha_context.origination; preorigination : Contract.t; } -> Kind.origination internal_operation_contents_result @@ -79,8 +79,8 @@ let result_of_internal_operation (type kind) let operation : kind internal_operation_contents_result = match operation with | Script_typed_ir.Transaction {transaction; _} -> Transaction transaction - | Script_typed_ir.Origination {manager_origination; preorigination; _} -> - Origination {manager_origination; preorigination} + | Script_typed_ir.Origination {origination; preorigination; _} -> + Origination {origination; preorigination} | Script_typed_ir.Delegation delegate -> Delegation delegate | Script_typed_ir.Tx_rollup_commit tx_rollup_commit -> Tx_rollup_commit tx_rollup_commit @@ -733,13 +733,12 @@ module Internal_result = struct proj = (function | Origination - {manager_origination = {credit; delegate; script}; preorigination} - -> + {origination = {credit; delegate; script}; preorigination} -> (credit, delegate, script, preorigination)); inj = (fun (credit, delegate, script, preorigination) -> Origination - {manager_origination = {credit; delegate; script}; preorigination}); + {origination = {credit; delegate; script}; preorigination}); } let[@coq_axiom_with_reason "gadt"] delegation_case = diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index 49aacf6a347d..af31a3001264 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -38,7 +38,7 @@ type 'kind internal_operation_contents_result = Alpha_context.transaction -> Kind.transaction internal_operation_contents_result | Origination : { - manager_origination : Alpha_context.manager_origination; + origination : Alpha_context.origination; preorigination : Contract.t; } -> Kind.origination internal_operation_contents_result diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index a2d7724798b4..da3a3e3fbf7f 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -183,7 +183,7 @@ type transaction = { destination : Destination_repr.t; } -type manager_origination = { +type origination = { delegate : Signature.Public_key_hash.t option; script : Script_repr.t; credit : Tez_repr.tez; @@ -265,7 +265,7 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : transaction -> Kind.transaction manager_operation - | Origination : manager_origination -> Kind.origination manager_operation + | Origination : origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 4d464e83da6f..2d52a1087b71 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -162,7 +162,7 @@ type transaction = { destination : Destination_repr.t; } -type manager_origination = { +type origination = { delegate : Signature.Public_key_hash.t option; script : Script_repr.t; credit : Tez_repr.tez; @@ -244,7 +244,7 @@ and _ contents = and _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : transaction -> Kind.transaction manager_operation - | Origination : manager_origination -> Kind.origination manager_operation + | Origination : origination -> Kind.origination manager_operation | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 6b5a55a95dd8..3de40740560a 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -587,7 +587,7 @@ let create_contract (ctxt, sc) gas storage_type param_type lambda code views Gas.consume ctxt (Script.strip_locations_cost storage) >>?= fun ctxt -> let storage = strip_locations storage in Contract.fresh_contract_from_current_nonce ctxt >>?= fun (ctxt, contract) -> - let manager_origination = + let origination = { credit; delegate; @@ -608,7 +608,7 @@ let create_contract (ctxt, sc) gas storage_type param_type lambda code views } in let operation = - Origination {manager_origination; preorigination = contract; parsed_script} + Origination {origination; preorigination = contract; parsed_script} in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 2fd21f77d2fe..d4bf4e0c1903 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1423,7 +1423,7 @@ and 'kind manager_operation = } -> Kind.transaction manager_operation | Origination : { - manager_origination : Alpha_context.manager_origination; + origination : Alpha_context.origination; preorigination : Contract.t; parsed_script : ('arg, 'storage) script; } diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 2d91cf775521..62b1cfe4b69c 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1550,7 +1550,7 @@ and 'kind manager_operation = } -> Kind.transaction manager_operation | Origination : { - manager_origination : Alpha_context.manager_origination; + origination : Alpha_context.origination; preorigination : Contract.t; parsed_script : ('arg, 'storage) script; } diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index e055ab3045a9..4a48d30ca93f 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -342,7 +342,7 @@ let origination_operation ~ctxt ~src ~script ~orig_contract = operation = Origination { - manager_origination = {delegate = None; script; credit = Tez.one}; + origination = {delegate = None; script; credit = Tez.one}; preorigination = orig_contract; parsed_script; }; diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index 76c8106fdf40..50ed2c0b629a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -245,7 +245,7 @@ let origination_operation block ~src ~baker ~script ~storage ~forges_tickets = operation = Origination { - manager_origination = {delegate = None; script; credit = Tez.one}; + origination = {delegate = None; script; credit = Tez.one}; preorigination = orig_contract; parsed_script; }; diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 873a448f9e7d..6989af4537d4 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -178,7 +178,7 @@ let tickets_of_operation ctxt parameters; } -> tickets_of_transaction ctxt ~destination ~parameters_ty ~parameters - | Origination {manager_origination = _; preorigination; parsed_script} -> + | Origination {origination = _; preorigination; parsed_script} -> tickets_of_origination ctxt ~preorigination parsed_script | Delegation _ -> return (None, ctxt) | Tx_rollup_commit _ -> return (None, ctxt) -- GitLab From 02ad4888ad63bdd6891288299d85b777147915d6 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 16:41:47 +0100 Subject: [PATCH 62/63] Proto/Client: rename manager_origination to origination. --- src/proto_alpha/lib_client/operation_result.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index fb5a2cf29d98..3f6e1a1a6195 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -324,8 +324,8 @@ let manager_operation (type kind) kind manager_operation = match operation with | Transaction transaction -> Alpha_context.Transaction transaction - | Origination {manager_origination; preorigination = _} -> - Alpha_context.Origination manager_origination + | Origination {origination; preorigination = _} -> + Alpha_context.Origination origination | Delegation delegate -> Alpha_context.Delegation delegate | Tx_rollup_commit tx_rollup_commit -> Alpha_context.Tx_rollup_commit tx_rollup_commit -- GitLab From c9645a7aae9ee5374c4fdf58fe6769fc03a9d5d5 Mon Sep 17 00:00:00 2001 From: Nicolas Ayache Date: Mon, 28 Feb 2022 17:25:51 +0100 Subject: [PATCH 63/63] Proto/Michelson: expose some case tags from Operation_repr. We will use them also in Apply_results when internal operations are separated. --- src/proto_alpha/lib_protocol/alpha_context.mli | 6 ++++++ src/proto_alpha/lib_protocol/operation_repr.ml | 13 ++++++++++--- src/proto_alpha/lib_protocol/operation_repr.mli | 6 ++++++ 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 832978faa95d..cb49666e422c 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2496,10 +2496,16 @@ module Operation : sig val reveal_case : Kind.reveal Kind.manager case + val transaction_tag : int + val transaction_case : Kind.transaction Kind.manager case + val origination_tag : int + val origination_case : Kind.origination Kind.manager case + val delegation_tag : int + val delegation_case : Kind.delegation Kind.manager case val tx_rollup_origination_case : diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index da3a3e3fbf7f..fe2a125a532f 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -881,13 +881,20 @@ module Encoding = struct let reveal_case = make_manager_case 107 Manager_operations.reveal_case + let transaction_tag = 108 + let transaction_case = - make_manager_case 108 Manager_operations.transaction_case + make_manager_case transaction_tag Manager_operations.transaction_case + + let origination_tag = 109 let origination_case = - make_manager_case 109 Manager_operations.origination_case + make_manager_case origination_tag Manager_operations.origination_case + + let delegation_tag = 110 - let delegation_case = make_manager_case 110 Manager_operations.delegation_case + let delegation_case = + make_manager_case delegation_tag Manager_operations.delegation_case let register_global_constant_case = make_manager_case 111 Manager_operations.register_global_constant_case diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 2d52a1087b71..57b6350c7a28 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -369,10 +369,16 @@ module Encoding : sig val reveal_case : Kind.reveal Kind.manager case + val transaction_tag : int + val transaction_case : Kind.transaction Kind.manager case + val origination_tag : int + val origination_case : Kind.origination Kind.manager case + val delegation_tag : int + val delegation_case : Kind.delegation Kind.manager case val register_global_constant_case : -- GitLab