From 3244fbae4ba3a8ff9a4e99d81e845ca9249a8f81 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Mon, 17 May 2021 18:06:34 +0100 Subject: [PATCH 01/33] Global counter - initial cli --- src/proto_alpha/lib_client/client_proto_context.ml | 4 ++++ src/proto_alpha/lib_client/client_proto_context.mli | 6 ++++++ .../client_proto_context_commands.ml | 10 ++++++++++ src/proto_alpha/lib_protocol/raw_context.ml | 10 ++++++++++ src/proto_alpha/lib_protocol/raw_context.mli | 5 +++++ 5 files changed, 35 insertions(+) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 512868659cc..01ce7925af3 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -33,6 +33,10 @@ open Client_keys let get_balance (rpc : #rpc_context) ~chain ~block contract = Alpha_services.Contract.balance rpc (chain, block) contract +let get_global_counter (rpc : #rpc_context) ~chain ~block = + ignore (rpc, chain, block) ; + return 42 + let get_storage (rpc : #rpc_context) ~chain ~block ~unparsing_mode contract = Plugin.RPC.Contract.get_storage_normalized rpc diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index c5255c31b5f..344d93053a0 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -79,6 +79,12 @@ val get_balance : Contract.t -> Tez.t tzresult Lwt.t +val get_global_counter : + #Protocol_client_context.rpc_context -> + chain:Shell_services.chain -> + block:Shell_services.block -> + int tzresult Lwt.t + val build_delegate_operation : ?fee:Tez.t -> ?gas_limit:Gas.Arith.integral -> diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index d21fbd37dfa..39d172908b1 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -262,6 +262,7 @@ let prepare_batch_operation cctxt ?arg ?fee ?gas_limit ?storage_limit return (Annotated_manager_operation.Annotated_manager_operation operation) let commands network () = + let () = print_endline "Joel debug: Alpha-protocol running" in let open Clic in [ command ~group @@ -303,6 +304,15 @@ let commands network () = >>=? fun amount -> cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym >>= fun () -> return_unit); + command + ~group + ~desc:"Get the global counter." + no_options + (prefixes ["get"; "global-counter"] stop) + (fun () (cctxt : Protocol_client_context.full) -> + get_global_counter cctxt ~chain:cctxt#chain ~block:cctxt#block + >>=? fun count -> + cctxt#answer "%a" Format.pp_print_int count >>= fun () -> return_unit); command ~group ~desc:"Get the storage of a contract." diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index a926957b16d..40df4f26cc5 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -76,6 +76,7 @@ type back = { internal_nonces_used : Int_set.t; remaining_block_gas : Gas_limit_repr.Arith.fp; unlimited_operation_gas : bool; + global_counter : int; } (* @@ -112,6 +113,8 @@ let[@inline] current_fitness ctxt = ctxt.back.fitness let[@inline] cycle_eras ctxt = ctxt.back.cycle_eras +let[@inline] global_counter ctxt = ctxt.back.global_counter + let[@inline] constants ctxt = ctxt.back.constants let[@inline] recover ctxt = ctxt.back.context @@ -196,6 +199,12 @@ let[@inline] update_temporary_lazy_storage_ids ctxt temporary_lazy_storage_ids = update_back ctxt {ctxt.back with temporary_lazy_storage_ids} +let[@inline] update_global_counter ctxt global_counter = + update_back ctxt {ctxt.back with global_counter} + +let[@inline] increment_global_counter ctxt = + update_global_counter ctxt (global_counter ctxt + 1) + let record_endorsement ctxt k = match Signature.Public_key_hash.Map.find_opt k (allowed_endorsements ctxt) @@ -739,6 +748,7 @@ let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = Gas_limit_repr.Arith.fp constants.Constants_repr.hard_gas_limit_per_block; unlimited_operation_gas = true; + global_counter = 0; }; } diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index 6cd245f918b..5c16e1f4970 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -97,6 +97,9 @@ val patch_constants : (** Retrieve the cycle eras. *) val cycle_eras : t -> Level_repr.cycle_eras +(** Retrieve the global-counter. *) +val global_counter : t -> int + (** Increment the current block fee stash that will be credited to baker's frozen_fees account at finalize_application *) val add_fees : t -> Tez_repr.t -> t tzresult @@ -145,6 +148,8 @@ val update_storage_space_to_pay : t -> Z.t -> t val update_allocated_contracts_count : t -> t +val increment_global_counter : t -> t + val clear_storage_space_to_pay : t -> t * Z.t * int type error += Undefined_operation_nonce (* `Permanent *) -- GitLab From 1c17ab2333b2e620c547a59eddebd42db61fa483 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 18 May 2021 09:36:44 +0100 Subject: [PATCH 02/33] RPC for global-counter --- .../lib_client/client_proto_context.ml | 6 ++++-- .../lib_client/client_proto_context.mli | 2 +- .../client_proto_context_commands.ml | 3 +-- src/proto_alpha/lib_protocol/alpha_context.ml | 4 ++++ .../lib_protocol/alpha_context.mli | 4 ++++ .../lib_protocol/alpha_services.ml | 19 +++++++++++++++++++ .../lib_protocol/alpha_services.mli | 4 ++++ 7 files changed, 37 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 01ce7925af3..f6a4cd4d9ec 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -34,8 +34,10 @@ let get_balance (rpc : #rpc_context) ~chain ~block contract = Alpha_services.Contract.balance rpc (chain, block) contract let get_global_counter (rpc : #rpc_context) ~chain ~block = - ignore (rpc, chain, block) ; - return 42 + Alpha_services.Global_variables.get rpc (chain, block) () + +(* ignore (rpc, chain, block) ;(chain, block) + return 42 *) let get_storage (rpc : #rpc_context) ~chain ~block ~unparsing_mode contract = Plugin.RPC.Contract.get_storage_normalized diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index 344d93053a0..12afd200930 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -83,7 +83,7 @@ val get_global_counter : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - int tzresult Lwt.t + int32 tzresult Lwt.t val build_delegate_operation : ?fee:Tez.t -> diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 39d172908b1..01d131a6f57 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -311,8 +311,7 @@ let commands network () = (prefixes ["get"; "global-counter"] stop) (fun () (cctxt : Protocol_client_context.full) -> get_global_counter cctxt ~chain:cctxt#chain ~block:cctxt#block - >>=? fun count -> - cctxt#answer "%a" Format.pp_print_int count >>= fun () -> return_unit); + >>=? fun count -> cctxt#answer "%ld" count >>= fun () -> return_unit); command ~group ~desc:"Get the storage of a contract." diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 23b46fcda0b..aa464151424 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -312,5 +312,9 @@ let get_rewards = Raw_context.get_rewards let description = Raw_context.description +let global_counter = Raw_context.global_counter + +let increment_global_counter = Raw_context.increment_global_counter + module Parameters = Parameters_repr module Liquidity_baking = Liquidity_baking_repr diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 62de39bf9ea..5d44df78c2d 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1649,6 +1649,10 @@ val get_deposits : context -> Tez.t Signature.Public_key_hash.Map.t val description : context Storage_description.t +val global_counter : context -> int + +val increment_global_counter : context -> context + module Parameters : sig type bootstrap_account = { public_key_hash : public_key_hash; diff --git a/src/proto_alpha/lib_protocol/alpha_services.ml b/src/proto_alpha/lib_protocol/alpha_services.ml index f2b23f7b61b..b7f65e4d62b 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.ml +++ b/src/proto_alpha/lib_protocol/alpha_services.ml @@ -28,6 +28,25 @@ open Alpha_context let custom_root = RPC_path.open_root +module Global_variables = struct + module S = struct + let get = + RPC_service.get_service + ~description:"Global counter" + ~query:RPC_query.empty + ~output:Data_encoding.int32 + RPC_path.(custom_root / "context" / "global-counter") + end + + let () = + let open Services_registration in + register0 S.get (fun ctxt () () -> + (* TODO: Joel change to int32 *) + return @@ Int32.of_int @@ Alpha_context.global_counter ctxt) + + let get ctxt block = RPC_context.make_call0 S.get ctxt block () +end + module Seed = struct module S = struct open Data_encoding diff --git a/src/proto_alpha/lib_protocol/alpha_services.mli b/src/proto_alpha/lib_protocol/alpha_services.mli index 2a44c99e1c4..46a3e24055a 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.mli +++ b/src/proto_alpha/lib_protocol/alpha_services.mli @@ -50,4 +50,8 @@ module Liquidity_baking : sig Alpha_context.Contract.t shell_tzresult Lwt.t end +module Global_variables : sig + val get : 'a #RPC_context.simple -> 'a -> unit -> int32 shell_tzresult Lwt.t +end + val register : unit -> unit -- GitLab From d3c38560c9b19b96ed31dce72882beea15290232 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 18 May 2021 14:46:46 +0100 Subject: [PATCH 03/33] Adding globa-counter-increase instruction --- .../lib_client/client_proto_context.ml | 2 +- src/proto_alpha/lib_client/injection.ml | 7 ++++ .../lib_client/operation_result.ml | 14 +++++++- .../lib_protocol/alpha_context.mli | 4 +++ .../lib_protocol/alpha_services.ml | 3 +- .../lib_protocol/alpha_services.mli | 3 +- src/proto_alpha/lib_protocol/apply.ml | 2 ++ src/proto_alpha/lib_protocol/apply_results.ml | 32 +++++++++++++++++++ .../lib_protocol/apply_results.mli | 4 +++ .../lib_protocol/operation_repr.ml | 10 ++++++ .../lib_protocol/operation_repr.mli | 4 +++ src/proto_alpha/lib_protocol/raw_context.ml | 2 +- .../lib_protocol/test/helpers/block.ml | 2 ++ 13 files changed, 84 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index f6a4cd4d9ec..3c548c31f1a 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -34,7 +34,7 @@ let get_balance (rpc : #rpc_context) ~chain ~block contract = Alpha_services.Contract.balance rpc (chain, block) contract let get_global_counter (rpc : #rpc_context) ~chain ~block = - Alpha_services.Global_variables.get rpc (chain, block) () + Alpha_services.Global_variables.get_global_counter rpc (chain, block) () (* ignore (rpc, chain, block) ;(chain, block) return 42 *) diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 6dc8d6e68fd..c31b518ee94 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -335,6 +335,8 @@ let estimated_gas_single (type kind) Ok consumed_gas | Applied (Delegation_result {consumed_gas}) -> Ok consumed_gas + | Applied (Global_counter_increment_result {consumed_gas}) -> + Ok consumed_gas | Skipped _ -> assert false | Backtracked (_, None) -> @@ -368,6 +370,8 @@ let estimated_storage_single (type kind) origination_size Ok Z.zero | Applied (Delegation_result _) -> Ok Z.zero + | Applied (Global_counter_increment_result _) -> + Ok Z.zero | Skipped _ -> assert false | Backtracked (_, None) -> @@ -413,6 +417,9 @@ let originated_contracts_single (type kind) Ok [] | Applied (Delegation_result _) -> Ok [] + | Applied (Global_counter_increment_result _) -> + (* TODO: JOEL not sure about this*) + Ok [] | Skipped _ -> assert false | Backtracked (_, None) -> diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml index 39cde840a0f..d9857f61ed0 100644 --- a/src/proto_alpha/lib_client/operation_result.ml +++ b/src/proto_alpha/lib_client/operation_result.ml @@ -130,7 +130,9 @@ let pp_manager_operation_content (type kind) source internal pp_result ppf Signature.Public_key_hash.pp delegate pp_result - result ) ; + result + | Global_counter_increment -> + Format.fprintf ppf "Increment global counter" ) ; Format.fprintf ppf "@]" let pp_balance_updates ppf = function @@ -319,6 +321,11 @@ let pp_manager_operation_contents_and_result ppf | Applied (Delegation_result {consumed_gas}) -> Format.fprintf ppf "This delegation was successfully applied" ; Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas + | Applied (Global_counter_increment_result {consumed_gas}) -> + Format.fprintf + ppf + "This increment counter operation was succesfully applied" ; + Format.fprintf ppf "@,Consumed gas: %a" Gas.Arith.pp consumed_gas | Backtracked (Delegation_result _, _) -> Format.fprintf ppf @@ -327,6 +334,11 @@ let pp_manager_operation_contents_and_result ppf | Applied (Transaction_result _ as tx) -> Format.fprintf ppf "This transaction was successfully applied" ; pp_transaction_result tx + | Backtracked (Global_counter_increment_result _, _) -> + Format.fprintf + ppf + "@[This increment global counter transaction was BACKTRACKED, \ + its expected effects were NOT applied.@]" | Backtracked ((Transaction_result _ as tx), _errs) -> Format.fprintf ppf diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 5d44df78c2d..5523fa0eae0 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1255,6 +1255,8 @@ module Kind : sig type delegation = Delegation_kind + type global_counter_increment = Global_counter_increment + type failing_noop = Failing_noop_kind type 'a manager = @@ -1262,6 +1264,7 @@ module Kind : sig | Transaction_manager_kind : transaction manager | Origination_manager_kind : origination manager | Delegation_manager_kind : delegation manager + | Global_counter_increment_kind : global_counter_increment manager end type 'kind operation = { @@ -1351,6 +1354,7 @@ and _ manager_operation = | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation + | Global_counter_increment : Kind.global_counter_increment manager_operation and counter = Z.t diff --git a/src/proto_alpha/lib_protocol/alpha_services.ml b/src/proto_alpha/lib_protocol/alpha_services.ml index b7f65e4d62b..21b518d9704 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.ml +++ b/src/proto_alpha/lib_protocol/alpha_services.ml @@ -44,7 +44,8 @@ module Global_variables = struct (* TODO: Joel change to int32 *) return @@ Int32.of_int @@ Alpha_context.global_counter ctxt) - let get ctxt block = RPC_context.make_call0 S.get ctxt block () + let get_global_counter ctxt block = + RPC_context.make_call0 S.get ctxt block () end module Seed = struct diff --git a/src/proto_alpha/lib_protocol/alpha_services.mli b/src/proto_alpha/lib_protocol/alpha_services.mli index 46a3e24055a..6241bb20636 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.mli +++ b/src/proto_alpha/lib_protocol/alpha_services.mli @@ -51,7 +51,8 @@ module Liquidity_baking : sig end module Global_variables : sig - val get : 'a #RPC_context.simple -> 'a -> unit -> int32 shell_tzresult Lwt.t + val get_global_counter : + 'a #RPC_context.simple -> 'a -> unit -> int32 shell_tzresult Lwt.t end val register : unit -> unit diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 91235021599..6e4fbdb37f4 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -748,6 +748,8 @@ let apply_manager_operation_content : Delegation_result {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}, [] ) + | Global_counter_increment -> + failwith "JOEL: TODO" type success_or_failure = Success of context | Failure diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index da0867bd95e..b2a00fb8bf1 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -75,6 +75,10 @@ type _ successful_manager_operation_result = consumed_gas : Gas.Arith.fp; } -> Kind.delegation successful_manager_operation_result + | Global_counter_increment_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.global_counter_increment successful_manager_operation_result let migration_origination_result_to_successful_manager_operation_result ({ balance_updates; @@ -513,6 +517,10 @@ let equal_manager_kind : Some Eq | (Kind.Delegation_manager_kind, _) -> None + | (Kind.Global_counter_increment_kind, Kind.Global_counter_increment_kind) -> + Some Eq + | (Kind.Global_counter_increment_kind, _) -> + None module Encoding = struct type 'kind case = @@ -1151,6 +1159,30 @@ let kind_equal : Some Eq | (Manager_operation {operation = Delegation _; _}, _) -> None + | ( Manager_operation {operation = Global_counter_increment; _}, + Manager_operation_result + {operation_result = Applied (Global_counter_increment_result _); _} ) + -> + Some Eq + | ( Manager_operation {operation = Global_counter_increment; _}, + Manager_operation_result + { operation_result = Backtracked (Global_counter_increment_result _, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Global_counter_increment; _}, + Manager_operation_result + { operation_result = + Failed (Alpha_context.Kind.Global_counter_increment_kind, _); + _ } ) -> + Some Eq + | ( Manager_operation {operation = Global_counter_increment; _}, + Manager_operation_result + { operation_result = + Skipped Alpha_context.Kind.Global_counter_increment_kind; + _ } ) -> + Some Eq + | (Manager_operation {operation = Global_counter_increment; _}, _) -> + None let rec kind_equal_list : type kind kind2. diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index fb05987c7ed..3dc6170f149 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -126,6 +126,10 @@ and _ successful_manager_operation_result = consumed_gas : Gas.Arith.fp; } -> Kind.delegation successful_manager_operation_result + | Global_counter_increment_result : { + consumed_gas : Gas.Arith.fp; + } + -> Kind.global_counter_increment successful_manager_operation_result and packed_successful_manager_operation_result = | Successful_manager_result : diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 5666100d52f..dccb1896bfb 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -50,6 +50,8 @@ module Kind = struct type delegation = Delegation_kind + type global_counter_increment = Global_counter_increment + type failing_noop = Failing_noop_kind type 'a manager = @@ -57,6 +59,7 @@ module Kind = struct | Transaction_manager_kind : transaction manager | Origination_manager_kind : origination manager | Delegation_manager_kind : delegation manager + | Global_counter_increment_kind : global_counter_increment manager end type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} @@ -150,6 +153,7 @@ and _ manager_operation = | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation + | Global_counter_increment : Kind.global_counter_increment manager_operation and counter = Z.t @@ -163,6 +167,8 @@ let manager_kind : type kind. kind manager_operation -> kind Kind.manager = Kind.Origination_manager_kind | Delegation _ -> Kind.Delegation_manager_kind + | Global_counter_increment -> + Kind.Global_counter_increment_kind type 'kind internal_operation = { source : Contract_repr.contract; @@ -836,6 +842,10 @@ let equal_manager_operation_kind : Some Eq | (Delegation _, _) -> None + | (Global_counter_increment, Global_counter_increment) -> + Some Eq + | (Global_counter_increment, _) -> + None let equal_contents_kind : type a b. a contents -> b contents -> (a, b) eq option = diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 20b3fb7ce49..e4f6f1591a6 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -52,11 +52,14 @@ module Kind : sig type failing_noop = Failing_noop_kind + type global_counter_increment = Global_counter_increment + type 'a manager = | Reveal_manager_kind : reveal manager | Transaction_manager_kind : transaction manager | Origination_manager_kind : origination manager | Delegation_manager_kind : delegation manager + | Global_counter_increment_kind : global_counter_increment manager end type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} @@ -150,6 +153,7 @@ and _ manager_operation = | Delegation : Signature.Public_key_hash.t option -> Kind.delegation manager_operation + | Global_counter_increment : Kind.global_counter_increment manager_operation and counter = Z.t diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 40df4f26cc5..a933e238888 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -748,7 +748,7 @@ let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = Gas_limit_repr.Arith.fp constants.Constants_repr.hard_gas_limit_per_block; unlimited_operation_gas = true; - global_counter = 0; + global_counter = 37; }; } diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 5d6bcadd438..22f0ef95537 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -611,6 +611,7 @@ let bake_n_with_all_balance_updates ?policy ?liquidity_baking_escape_vote n b = let open Apply_results in function | Successful_manager_result (Reveal_result _) + | Successful_manager_result (Global_counter_increment_result _) | Successful_manager_result (Delegation_result _) -> balance_updates_rev | Successful_manager_result @@ -638,6 +639,7 @@ let bake_n_with_origination_results ?policy n b = function | Successful_manager_result (Reveal_result _) | Successful_manager_result (Delegation_result _) + | Successful_manager_result (Global_counter_increment_result _) | Successful_manager_result (Transaction_result _) -> origination_results_rev | Successful_manager_result (Origination_result x) -> -- GitLab From cd2221f3caad76bf0eaf2d7958c783be394fdc29 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 19 May 2021 12:04:55 +0100 Subject: [PATCH 04/33] Command for incrementing the counter --- .../lib_client/client_proto_context.ml | 46 ++++++- .../lib_client/client_proto_context.mli | 26 ++++ .../client_proto_context_commands.ml | 130 +++++++++++++++--- .../lib_protocol/alpha_services.ml | 2 +- src/proto_alpha/lib_protocol/apply.ml | 5 +- 5 files changed, 184 insertions(+), 25 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 3c548c31f1a..5425e619c20 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -36,9 +36,6 @@ let get_balance (rpc : #rpc_context) ~chain ~block contract = let get_global_counter (rpc : #rpc_context) ~chain ~block = Alpha_services.Global_variables.get_global_counter rpc (chain, block) () -(* ignore (rpc, chain, block) ;(chain, block) - return 42 *) - let get_storage (rpc : #rpc_context) ~chain ~block ~unparsing_mode contract = Plugin.RPC.Contract.get_storage_normalized rpc @@ -151,6 +148,49 @@ let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run | Apply_results.Single_and_result ((Manager_operation _ as op), result) -> return ((oph, op, result), contracts) +let build_incremenent_global_counter_operation ?fee ?gas_limit ?storage_limit + () = + Injection.prepare_manager_operation + ~fee:(Limit.of_option fee) + ~gas_limit:(Limit.of_option gas_limit) + ~storage_limit:(Limit.of_option storage_limit) + Global_counter_increment + +let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations + ?dry_run ?verbose_signing ?branch ~source ~src_pk ~src_sk ?fee ?gas_limit + ?storage_limit ?counter ~fee_parameter () = + let contents = + build_incremenent_global_counter_operation + ?fee + ?gas_limit + ?storage_limit + () + in + let contents = Annotated_manager_operation.Single_manager contents in + Injection.inject_manager_operation + cctxt + ~chain + ~block + ?confirmations + ?dry_run + ?verbose_signing + ?branch + ~source + ~fee:(Limit.of_option fee) + ~gas_limit:(Limit.of_option gas_limit) + ~storage_limit:(Limit.of_option storage_limit) + ?counter + ~src_pk + ~src_sk + ~fee_parameter + contents + >>=? fun (oph, op, result) -> + Lwt.return (Injection.originated_contracts result) + >>=? fun contracts -> + match Apply_results.pack_contents_list op result with + | Apply_results.Single_and_result ((Manager_operation _ as op), result) -> + return ((oph, op, result), contracts) + let build_reveal_operation ?fee ?gas_limit ?storage_limit pk = let operation = Reveal pk in Injection.prepare_manager_operation diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index 12afd200930..f7295f9dd74 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -187,6 +187,32 @@ val transfer : (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult Lwt.t +val increment_global_counter : + #Protocol_client_context.full -> + chain:Shell_services.chain -> + block:Shell_services.block -> + ?confirmations:int -> + ?dry_run:bool -> + ?verbose_signing:bool -> + ?branch:int -> + source:public_key_hash -> + src_pk:public_key -> + src_sk:Client_keys.sk_uri -> + ?fee:Tez.t -> + ?gas_limit:Fixed_point_repr.integral_tag Gas.Arith.t -> + ?storage_limit:counter -> + ?counter:counter -> + fee_parameter:Injection.fee_parameter -> + unit -> + ( ( Operation_hash.t + * Kind.global_counter_increment Kind.manager contents + * Kind.global_counter_increment Kind.manager Apply_results.contents_result + ) + * Contract.t trace, + error trace ) + result + Lwt.t + val build_reveal_operation : ?fee:Tez.t -> ?gas_limit:Gas.Arith.integral -> diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 01d131a6f57..5deecb7a873 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -114,6 +114,62 @@ let alphanet = {Clic.name = "alphanet"; title = "Alphanet only commands"} let binary_description = {Clic.name = "description"; title = "Binary Description"} +let increment_global_counter_command source cctxt + ( fee, + dry_run, + verbose_signing, + gas_limit, + storage_limit, + counter, + no_print_source, + minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) = + let fee_parameter = + { + Injection.minimal_fees; + minimal_nanotez_per_byte; + minimal_nanotez_per_gas_unit; + force_low_fee; + fee_cap; + burn_cap; + } + in + ( match Contract.is_implicit source with + | None -> + Managed_contract.get_contract_manager cctxt source + >>=? fun source -> + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> return (src_pk, src_sk, source) + | Some source -> + Client_keys.get_key cctxt source + >>=? fun (_, src_pk, src_sk) -> return (src_pk, src_sk, source) ) + >>=? fun (src_pk, src_sk, source) -> + Client_proto_context.increment_global_counter + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ?gas_limit + ?storage_limit + ?counter + () + >>= report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + >>= function None -> return_unit | Some (_res, _contracts) -> return_unit + let transfer_command amount source destination cctxt ( fee, dry_run, @@ -312,26 +368,6 @@ let commands network () = (fun () (cctxt : Protocol_client_context.full) -> get_global_counter cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun count -> cctxt#answer "%ld" count >>= fun () -> return_unit); - command - ~group - ~desc:"Get the storage of a contract." - (args1 (unparsing_mode_arg ~default:"Readable")) - ( prefixes ["get"; "contract"; "storage"; "for"] - @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" - @@ stop ) - (fun unparsing_mode (_, contract) (cctxt : Protocol_client_context.full) -> - get_storage - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~unparsing_mode - contract - >>=? function - | None -> - cctxt#error "This is not a smart contract." - | Some storage -> - cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage - >>= fun () -> return_unit); command ~group ~desc: @@ -1012,6 +1048,60 @@ let commands network () = fee_cap, burn_cap, entrypoint )); + (* Increment global counter command *) + command + ~group + ~desc:"Increment global counter." + (args13 + fee_arg + dry_run_switch + verbose_signing_switch + gas_limit_arg + storage_limit_arg + counter_arg + no_print_source_flag + minimal_fees_arg + minimal_nanotez_per_byte_arg + minimal_nanotez_per_gas_unit_arg + force_low_fee_arg + fee_cap_arg + burn_cap_arg) + ( prefixes ["increment-global-counter"] + @@ ContractAlias.destination_param + ~name:"src" + ~desc:"name of the source contract" + @@ stop ) + (fun ( fee, + dry_run, + verbose_signing, + gas_limit, + storage_limit, + counter, + no_print_source, + minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap ) + (_, source) + cctxt -> + increment_global_counter_command + source + cctxt + ( fee, + dry_run, + verbose_signing, + gas_limit, + storage_limit, + counter, + no_print_source, + minimal_fees, + minimal_nanotez_per_byte, + minimal_nanotez_per_gas_unit, + force_low_fee, + fee_cap, + burn_cap )); command ~group ~desc:"Call a smart contract (same as 'transfer 0')." diff --git a/src/proto_alpha/lib_protocol/alpha_services.ml b/src/proto_alpha/lib_protocol/alpha_services.ml index 21b518d9704..3104e85f770 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.ml +++ b/src/proto_alpha/lib_protocol/alpha_services.ml @@ -32,7 +32,7 @@ module Global_variables = struct module S = struct let get = RPC_service.get_service - ~description:"Global counter" + ~description:"Get global counter" ~query:RPC_query.empty ~output:Data_encoding.int32 RPC_path.(custom_root / "context" / "global-counter") diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 6e4fbdb37f4..d7b2676f0c1 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -749,7 +749,10 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}, [] ) | Global_counter_increment -> - failwith "JOEL: TODO" + return + ( Alpha_context.increment_global_counter ctxt, + Global_counter_increment_result {consumed_gas = Gas.Arith.zero}, + [] ) type success_or_failure = Success of context | Failure -- GitLab From f058fa93081a3ed37fb958a968cf7508fa11e0fa Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 19 May 2021 15:26:45 +0100 Subject: [PATCH 05/33] Prepare global counter --- .../lib_protocol/alpha_context.mli | 3 +- .../lib_protocol/alpha_services.ml | 3 +- src/proto_alpha/lib_protocol/init_storage.ml | 11 +++++-- src/proto_alpha/lib_protocol/init_storage.mli | 1 + src/proto_alpha/lib_protocol/main.ml | 30 +++++++++++++++++-- src/proto_alpha/lib_protocol/raw_context.ml | 19 ++++++++---- src/proto_alpha/lib_protocol/raw_context.mli | 3 +- .../lib_protocol/services_registration.ml | 3 ++ .../test/helpers/sapling_helpers.ml | 5 ++++ .../lib_protocol/test/test_baking.ml | 1 + .../lib_protocol/test/test_gas_levels.ml | 1 + .../lib_protocol/test/test_rolls.ml | 2 ++ .../lib_protocol/test/test_sapling.ml | 9 ++++++ .../lib_protocol/test/test_temp_big_maps.ml | 1 + 14 files changed, 78 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 5523fa0eae0..3afbe402f69 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1609,6 +1609,7 @@ val prepare : predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> + global_counter:int32 -> (context * Receipt.balance_updates * Migration.origination_result list) tzresult Lwt.t @@ -1653,7 +1654,7 @@ val get_deposits : context -> Tez.t Signature.Public_key_hash.Map.t val description : context Storage_description.t -val global_counter : context -> int +val global_counter : context -> int32 val increment_global_counter : context -> context diff --git a/src/proto_alpha/lib_protocol/alpha_services.ml b/src/proto_alpha/lib_protocol/alpha_services.ml index 3104e85f770..0f159f76a72 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.ml +++ b/src/proto_alpha/lib_protocol/alpha_services.ml @@ -41,8 +41,7 @@ module Global_variables = struct let () = let open Services_registration in register0 S.get (fun ctxt () () -> - (* TODO: Joel change to int32 *) - return @@ Int32.of_int @@ Alpha_context.global_counter ctxt) + return @@ Alpha_context.global_counter ctxt) let get_global_counter ctxt block = RPC_context.make_call0 S.get ctxt block () diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index 626405dbe65..765659b6dfa 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -118,6 +118,13 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = >>=? fun (ctxt, operation_results) -> Storage.Pending_migration.Operation_results.init ctxt operation_results -let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness = - Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt +let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness + ~global_counter = + Raw_context.prepare + ~level + ~predecessor_timestamp + ~timestamp + ~fitness + ~global_counter + ctxt >>=? fun ctxt -> Storage.Pending_migration.remove ctxt diff --git a/src/proto_alpha/lib_protocol/init_storage.mli b/src/proto_alpha/lib_protocol/init_storage.mli index 14cd0ed5f9d..f5c0f7e6f7f 100644 --- a/src/proto_alpha/lib_protocol/init_storage.mli +++ b/src/proto_alpha/lib_protocol/init_storage.mli @@ -43,6 +43,7 @@ val prepare : predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> + global_counter:int32 -> ( Raw_context.t * Receipt_repr.balance_updates * Migration_repr.origination_result list ) diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index d6cbf7b217e..f5ecc04887d 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -123,7 +123,15 @@ let begin_partial_application ~chain_id ~ancestor_context:ctxt let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + (* TODO: Joel fetch *) + let global_counter = 39l in + Alpha_context.prepare + ~level + ~predecessor_timestamp + ~timestamp + ~fitness + ~global_counter + ctxt >>=? fun (ctxt, migration_balance_updates, migration_operation_results) -> Apply.begin_application ctxt chain_id block_header predecessor_timestamp >|=? fun ( ctxt, @@ -152,7 +160,15 @@ let begin_application ~chain_id ~predecessor_context:ctxt let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + (* TODO: Joel fetch - perhaps pass as bytes? *) + let global_counter = 40l in + Alpha_context.prepare + ~level + ~predecessor_timestamp + ~timestamp + ~fitness + ~global_counter + ctxt >>=? fun (ctxt, migration_balance_updates, migration_operation_results) -> Apply.begin_application ctxt chain_id block_header predecessor_timestamp >|=? fun ( ctxt, @@ -181,7 +197,15 @@ let begin_construction ~chain_id ~predecessor_context:ctxt ?(protocol_data : block_header_data option) () = let level = Int32.succ pred_level in let fitness = pred_fitness in - Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt + (* TODO: Joel pass as bytes? *) + let global_counter = 41l in + Alpha_context.prepare + ~level + ~predecessor_timestamp + ~timestamp + ~fitness + ~global_counter + ctxt >>=? fun (ctxt, migration_balance_updates, migration_operation_results) -> ( match protocol_data with | None -> diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index a933e238888..f051bd4682d 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -76,7 +76,7 @@ type back = { internal_nonces_used : Int_set.t; remaining_block_gas : Gas_limit_repr.Arith.fp; unlimited_operation_gas : bool; - global_counter : int; + global_counter : int32; } (* @@ -203,7 +203,7 @@ let[@inline] update_global_counter ctxt global_counter = update_back ctxt {ctxt.back with global_counter} let[@inline] increment_global_counter ctxt = - update_global_counter ctxt (global_counter ctxt + 1) + update_global_counter ctxt (Int32.add (global_counter ctxt) 1l) let record_endorsement ctxt k = match @@ -709,7 +709,8 @@ let check_cycle_eras (cycle_eras : Level_repr.cycle_eras) Compare.Int32.( current_era.blocks_per_commitment = constants.blocks_per_commitment) ) -let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = +let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ~global_counter + ctxt = Raw_level_repr.of_int32 level >>?= fun level -> Fitness_repr.to_int64 fitness @@ -748,7 +749,7 @@ let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = Gas_limit_repr.Arith.fp constants.Constants_repr.hard_gas_limit_per_block; unlimited_operation_gas = true; - global_counter = 37; + global_counter; }; } @@ -926,7 +927,15 @@ let prepare_first_block ~level ~timestamp ~fitness ctxt = Level_repr.create_cycle_eras [second_cycle_era; first_cycle_era] >>?= fun cycle_eras -> set_cycle_eras ctxt cycle_eras ) >>=? fun ctxt -> - prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness + (* TODO: Joel to dig out*) + let global_counter = 38l in + prepare + ctxt + ~level + ~predecessor_timestamp:timestamp + ~timestamp + ~fitness + ~global_counter >|=? fun ctxt -> (previous_proto, ctxt) let activate ctxt h = Updater.activate (context ctxt) h >|= update_context ctxt diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index 5c16e1f4970..d690ac5091e 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -61,6 +61,7 @@ val prepare : predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> + global_counter:int32 -> Context.t -> t tzresult Lwt.t @@ -98,7 +99,7 @@ val patch_constants : val cycle_eras : t -> Level_repr.cycle_eras (** Retrieve the global-counter. *) -val global_counter : t -> int +val global_counter : t -> int32 (** Increment the current block fee stash that will be credited to baker's frozen_fees account at finalize_application *) diff --git a/src/proto_alpha/lib_protocol/services_registration.ml b/src/proto_alpha/lib_protocol/services_registration.ml index 95330034977..323fafef9d6 100644 --- a/src/proto_alpha/lib_protocol/services_registration.ml +++ b/src/proto_alpha/lib_protocol/services_registration.ml @@ -35,11 +35,14 @@ let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) = let level = block_header.level in let timestamp = block_header.timestamp in let fitness = block_header.fitness in + (* TODO: Joel, dig out from context? *) + let global_counter = 42l in Alpha_context.prepare ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness + ~global_counter context >|=? fun (context, _, _) -> {block_hash; block_header; context} diff --git a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml index b6e5a0a2f8d..c7bd5d44965 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml @@ -153,12 +153,15 @@ module Alpha_context_helpers = struct let init () = Context.init 1 >>=? fun (b, _) -> + (* TODO: Joel dig this from context? *) + let global_counter = 43l in Alpha_context.prepare b.context ~level:b.header.shell.level ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter >>= wrap >|=? fun (ctxt, _, _) -> ctxt @@ -224,6 +227,7 @@ module Alpha_context_helpers = struct >>=? fun (ctx, id) -> let ectx = (Alpha_context.finalize ctx).context in (* bump the level *) + let global_counter = Alpha_context.global_counter ctx in Alpha_context.prepare ectx ~level: @@ -232,6 +236,7 @@ module Alpha_context_helpers = struct ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) ~timestamp:(Time.Protocol.of_seconds Int64.zero) ~fitness:(Fitness_repr.from_int64 Int64.zero) + ~global_counter >>= wrap >|=? fun (ctx, _, _) -> Some (ctx, id) diff --git a/src/proto_alpha/lib_protocol/test/test_baking.ml b/src/proto_alpha/lib_protocol/test/test_baking.ml index a629ffc203d..5eac2ced198 100644 --- a/src/proto_alpha/lib_protocol/test/test_baking.ml +++ b/src/proto_alpha/lib_protocol/test/test_baking.ml @@ -230,6 +230,7 @@ let test_rewards_formulas_equivalence () = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun (ctxt, _, _) -> let block_priorities = 0 -- 64 in diff --git a/src/proto_alpha/lib_protocol/test/test_gas_levels.ml b/src/proto_alpha/lib_protocol/test/test_gas_levels.ml index 90b22f9a438..4f7f2345a63 100644 --- a/src/proto_alpha/lib_protocol/test/test_gas_levels.ml +++ b/src/proto_alpha/lib_protocol/test/test_gas_levels.ml @@ -54,6 +54,7 @@ let dummy_context () = ~predecessor_timestamp:Time.Protocol.epoch ~timestamp:Time.Protocol.epoch ~fitness:[] + ~global_counter:0l (block.context : Environment_context.Context.t) >|= Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_protocol/test/test_rolls.ml b/src/proto_alpha/lib_protocol/test/test_rolls.ml index dd2af08f874..5da8a11ab36 100644 --- a/src/proto_alpha/lib_protocol/test/test_rolls.ml +++ b/src/proto_alpha/lib_protocol/test/test_rolls.ml @@ -66,6 +66,7 @@ let check_rolls (b : Block.t) (account : Account.t) = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctxt -> Roll_storage.count_rolls ctxt account.pkh @@ -80,6 +81,7 @@ let check_no_rolls (b : Block.t) (account : Account.t) = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctxt -> Roll_storage.count_rolls ctxt account.pkh diff --git a/src/proto_alpha/lib_protocol/test/test_sapling.ml b/src/proto_alpha/lib_protocol/test/test_sapling.ml index 64b88d2151e..785cfb41c77 100644 --- a/src/proto_alpha/lib_protocol/test/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/test_sapling.ml @@ -48,6 +48,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctx -> let module H = Tezos_sapling.Core.Client.Hash in @@ -96,6 +97,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -134,6 +136,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -209,6 +212,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -266,6 +270,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -354,6 +359,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -378,6 +384,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l (Raw_context.recover ctx) >>= wrap >|=? fun ctx -> (ctx, Int32.succ cnt)) @@ -433,6 +440,7 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -1036,6 +1044,7 @@ module Interpreter_tests = struct ~predecessor_timestamp:block.header.shell.timestamp ~timestamp:block.header.shell.timestamp ~fitness:block.header.shell.fitness + ~global_counter:0l >>= wrap >>=? fun raw_ctx -> Sapling_storage.Roots.mem raw_ctx id root >>= wrap in diff --git a/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml b/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml index d6b12436ddc..512a5cf2788 100644 --- a/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml +++ b/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml @@ -39,6 +39,7 @@ let to_raw_context (b : Block.t) = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness + ~global_counter:0l >|= Environment.wrap_tzresult let check_no_dangling_temp_big_map b = -- GitLab From 1f30d68259dc744effd95b2ebf76ee9cfbae7dae Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 19 May 2021 19:49:01 +0100 Subject: [PATCH 06/33] Update storage (WIP) --- .../lib_client/client_proto_context.ml | 6 ++++ src/proto_alpha/lib_client/injection.ml | 34 +++++++++++++++++-- .../client_proto_context_commands.ml | 1 + src/proto_alpha/lib_protocol/alpha_context.ml | 4 ++- .../lib_protocol/alpha_context.mli | 2 +- src/proto_alpha/lib_protocol/apply.ml | 4 ++- .../lib_protocol/operation_repr.ml | 20 ++++++++++- src/proto_alpha/lib_protocol/storage.ml | 7 ++++ src/proto_alpha/lib_protocol/storage.mli | 8 +++++ 9 files changed, 80 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 5425e619c20..501d1eeab95 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -159,6 +159,7 @@ let build_incremenent_global_counter_operation ?fee ?gas_limit ?storage_limit let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch ~source ~src_pk ~src_sk ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = + let () = print_endline "Joel: Build inc conter op" in let contents = build_incremenent_global_counter_operation ?fee @@ -166,7 +167,9 @@ let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ?storage_limit () in + let () = print_endline "Joel: Create contents" in let contents = Annotated_manager_operation.Single_manager contents in + let () = print_endline "Joel: Inject manager operation " in Injection.inject_manager_operation cctxt ~chain @@ -185,10 +188,13 @@ let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ~fee_parameter contents >>=? fun (oph, op, result) -> + let () = print_endline "Joel: Inject originated contracts" in Lwt.return (Injection.originated_contracts result) >>=? fun contracts -> + let () = print_endline "Joel: Contracts should be empty" in match Apply_results.pack_contents_list op result with | Apply_results.Single_and_result ((Manager_operation _ as op), result) -> + let () = print_endline "Joel: Return operation hash etc" in return ((oph, op, result), contracts) let build_reveal_operation ?fee ?gas_limit ?storage_limit pk = diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index c31b518ee94..114d56f3f73 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -296,14 +296,18 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ?branch (contents : t contents_list) = + let () = print_endline "Joel: 1 get_branch" in get_branch cctxt ~chain ~block branch >>=? fun (_chain_id, branch) -> + let () = print_endline "Joel: 2 get hash" in let op : _ Operation.t = {shell = {branch}; protocol_data = {contents; signature = None}} in let oph = Operation.hash op in + let () = print_endline "Joel: got the hash" in Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> + let () = print_endline "Joel: 3 run_operation" in Plugin.RPC.Scripts.run_operation cctxt (chain, block) @@ -499,8 +503,10 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) ~fee_parameter ~chain ~block ?branch (annotated_contents : kind Annotated_manager_operation.annotated_list) : kind Kind.manager contents_list tzresult Lwt.t = + let () = print_endline "Joel: wait_for_bootstrapped" in Tezos_client_base.Client_confirmations.wait_for_bootstrapped cctxt >>=? fun () -> + let () = print_endline "Joel: 1" in Alpha_services.Constants.all cctxt (chain, block) >>=? fun { parametric = { hard_gas_limit_per_operation; @@ -509,6 +515,7 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) cost_per_byte; _ }; _ } -> + let () = print_endline "Joel: 2" in let user_gas_limit_needs_patching user_gas_limit = Limit.fold user_gas_limit ~unknown:true ~known:(fun user_gas_limit -> Gas.Arith.( @@ -697,41 +704,51 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun first annotated_list result_list -> match (annotated_list, result_list) with | (Single_manager annotated, Single_result res) -> + let () = print_endline "Joel: A" in patch ~first (annotated, res) >>=? fun op -> return (Single op) | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> + let () = print_endline "Joel: B" in patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) | _ -> + let () = print_endline "Joel: C (assert false)" in assert false in match may_need_patching annotated_contents with | Some annotated_for_simulation -> + let () = print_endline "Joel: 3 May need patching" in Lwt.return (Annotated_manager_operation.manager_list_from_annotated annotated_for_simulation) >>=? fun contents_for_simulation -> + let () = print_endline "Joel: 4 simulate:" in simulate cctxt ~chain ~block ?branch contents_for_simulation >>=? fun (_, _, result) -> ( match detect_script_failure result with | Ok () -> + let () = print_endline "Joel: ok" in return_unit | Error _ -> + let () = print_endline "Joel: simulation failed:" in cctxt#message "@[This simulation failed:@,%a@]" Operation_result.pp_operation_result (contents_for_simulation, result.contents) >>= fun () -> return_unit ) >>=? fun () -> + let () = print_endline "Joel: return" in Lwt.return (estimated_storage (Z.of_int origination_size) result.contents) >>=? (fun storage -> + let () = print_endline "Joel: got storage" in Lwt.return (Environment.wrap_tzresult Tez.(cost_per_byte *? Z.to_int64 storage)) >>=? fun burn -> + let () = print_endline "Joel: burn storage" in if Tez.(burn > fee_parameter.burn_cap) then cctxt#error "The operation will burn %s%a which is higher than the \ @@ -745,10 +762,15 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fee_parameter.burn_cap Tez.pp burn - >>= fun () -> exit 1 + >>= fun () -> + let () = print_endline "Joel: exit" in + exit 1 else return_unit) - >>=? fun () -> patch_list true annotated_contents result.contents + >>=? fun () -> + let () = print_endline "Joel: patch list " in + patch_list true annotated_contents result.contents | None -> + let () = print_endline "Joel: 4 No patching" in Lwt.return (Annotated_manager_operation.manager_list_from_annotated annotated_contents) @@ -779,6 +801,7 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations >>= fun () -> Lwt.return res ) >>=? fun () -> let bytes = + let () = print_endline "Call `to_bytes_exn`" in Data_encoding.Binary.to_bytes_exn Operation.encoding (Operation.pack op) in if dry_run || simulation then @@ -936,8 +959,10 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations | Some counter -> return counter ) >>=? fun counter -> + let () = print_endline "Joel: manager_key" in Alpha_services.Contract.manager_key cctxt (chain, block) source >>=? fun key -> + let () = print_endline "Joel: got key" in (* [has_reveal] assumes that a Reveal operation only appears as the first of a batch *) let has_reveal : type kind. kind Annotated_manager_operation.annotated_list -> bool = @@ -977,6 +1002,7 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations in match key with | None when not (has_reveal operations) -> ( + let () = print_endline "Joel: None key" in ( if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then reveal_error cctxt else return_unit ) @@ -1017,12 +1043,16 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations | _ -> assert false ) | Some _ when has_reveal operations -> + let () = print_endline "Joel: some fail" in failwith "The manager key was previously revealed." | _ -> + let () = print_endline "Joel: other - build_contents" in build_contents counter operations >>?= fun contents -> + let () = print_endline "Joel: my_patch" in may_patch_limits cctxt ~fee_parameter ~chain ~block ?branch contents >>=? fun contents -> + let () = print_endline "Joel: inject_operation_internal" in inject_operation_internal cctxt ~chain diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 5deecb7a873..9064c806e2d 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -148,6 +148,7 @@ let increment_global_counter_command source cctxt Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> return (src_pk, src_sk, source) ) >>=? fun (src_pk, src_sk, source) -> + let () = print_endline "Call increment_global_counter" in Client_proto_context.increment_global_counter cctxt ~chain:cctxt#chain diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index aa464151424..d12d60dd113 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -314,7 +314,9 @@ let description = Raw_context.description let global_counter = Raw_context.global_counter -let increment_global_counter = Raw_context.increment_global_counter +let increment_global_counter ctx = + Storage.Global_counter.get ctx + >>=? fun counter -> Storage.Global_counter.update ctx (Int32.add counter 1l) module Parameters = Parameters_repr module Liquidity_baking = Liquidity_baking_repr diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 3afbe402f69..31d29ef0bbe 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1656,7 +1656,7 @@ val description : context Storage_description.t val global_counter : context -> int32 -val increment_global_counter : context -> context +val increment_global_counter : context -> (context, error trace) result Lwt.t module Parameters : sig type bootstrap_account = { diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index d7b2676f0c1..b653d910ce6 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -749,8 +749,10 @@ let apply_manager_operation_content : {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}, [] ) | Global_counter_increment -> + Alpha_context.increment_global_counter ctxt + >>=? fun ctxt -> return - ( Alpha_context.increment_global_counter ctxt, + ( ctxt, Global_counter_increment_result {consumed_gas = Gas.Arith.zero}, [] ) diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index dccb1896bfb..e87faa71af0 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -364,6 +364,19 @@ module Encoding = struct inj = (fun key -> Delegation key); } + let[@coq_axiom_with_reason "gadt"] global_counter_increment_case = + MCase + { + tag = 4; + name = "global_counter_increment"; + encoding = obj1 (opt "global_counter_increment" string); + select = + (function + | Manager (Global_counter_increment as op) -> Some op | _ -> None); + proj = (function Global_counter_increment -> None); + inj = (fun _ -> Global_counter_increment); + } + let encoding = let make (MCase {tag; name; encoding; select; proj; inj}) = case @@ -379,7 +392,8 @@ module Encoding = struct [ make reveal_case; make transaction_case; make origination_case; - make delegation_case ] + make delegation_case; + make global_counter_increment_case ] end type 'b case = @@ -635,6 +649,9 @@ module Encoding = struct let delegation_case = make_manager_case 110 Manager_operations.delegation_case + let global_counter_increment_case = + make_manager_case 111 Manager_operations.global_counter_increment_case + let contents_encoding = let make (Case {tag; name; encoding; select; proj; inj}) = case @@ -658,6 +675,7 @@ module Encoding = struct make transaction_case; make origination_case; make delegation_case; + make global_counter_increment_case; make failing_noop_case ] let contents_list_encoding = diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index ae2ab52f0ca..5f73e22ac0e 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -82,6 +82,13 @@ module Make_index (H : Storage_description.INDEX) : let args = Storage_description.One {rpc_arg; encoding; compare} end +module Global_counter = + Make_single_data_storage (Registered) (Raw_context) + (struct + let name = ["global_counter_incrementable"] + end) + (Int32) + module Block_priority = Make_single_data_storage (Registered) (Raw_context) (struct diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index eef475d28b1..c47d53c703c 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -36,6 +36,14 @@ open Storage_sigs +module Global_counter : sig + val get : Raw_context.t -> int32 tzresult Lwt.t + + val update : Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t + + val init : Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t +end + module Block_priority : sig val get : Raw_context.t -> int tzresult Lwt.t -- GitLab From ec591c70f8183f09c42e3c07027ea1991c4815db Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Thu, 20 May 2021 13:43:12 +0100 Subject: [PATCH 07/33] Init global-counter in storage --- src/proto_alpha/lib_plugin/plugin.ml | 1 + src/proto_alpha/lib_protocol/alpha_context.ml | 7 ++++--- src/proto_alpha/lib_protocol/alpha_context.mli | 2 +- src/proto_alpha/lib_protocol/alpha_services.ml | 6 +++--- src/proto_alpha/lib_protocol/init_storage.ml | 2 ++ src/proto_alpha/lib_protocol/operation_repr.ml | 4 ++-- src/proto_alpha/lib_protocol/storage.ml | 2 +- src/proto_alpha/lib_protocol/storage.mli | 2 +- .../lib_protocol/test/helpers/sapling_helpers.ml | 4 +++- 9 files changed, 18 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index b9c08b88fb5..511231d9522 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1298,6 +1298,7 @@ module RPC = struct RPC_context.make_call0 S.normalize_type ctxt block () ty let run_operation ctxt block ~op ~chain_id = + let () = print_endline "Joel: make_call0" in RPC_context.make_call0 S.run_operation ctxt block () (op, chain_id) let entrypoint_type ctxt block ~script ~entrypoint = diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index d12d60dd113..f1a7747d4a1 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -312,11 +312,12 @@ let get_rewards = Raw_context.get_rewards let description = Raw_context.description -let global_counter = Raw_context.global_counter +let global_counter ctx = Storage.Incrementable_global_counter.get ctx let increment_global_counter ctx = - Storage.Global_counter.get ctx - >>=? fun counter -> Storage.Global_counter.update ctx (Int32.add counter 1l) + Storage.Incrementable_global_counter.get ctx + >>=? fun counter -> + Storage.Incrementable_global_counter.update ctx (Int32.add counter 1l) module Parameters = Parameters_repr module Liquidity_baking = Liquidity_baking_repr diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 31d29ef0bbe..f67b93c7f45 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1654,7 +1654,7 @@ val get_deposits : context -> Tez.t Signature.Public_key_hash.Map.t val description : context Storage_description.t -val global_counter : context -> int32 +val global_counter : context -> int32 tzresult Lwt.t val increment_global_counter : context -> (context, error trace) result Lwt.t diff --git a/src/proto_alpha/lib_protocol/alpha_services.ml b/src/proto_alpha/lib_protocol/alpha_services.ml index 0f159f76a72..d8e5394f526 100644 --- a/src/proto_alpha/lib_protocol/alpha_services.ml +++ b/src/proto_alpha/lib_protocol/alpha_services.ml @@ -38,10 +38,9 @@ module Global_variables = struct RPC_path.(custom_root / "context" / "global-counter") end - let () = + let register () = let open Services_registration in - register0 S.get (fun ctxt () () -> - return @@ Alpha_context.global_counter ctxt) + register0 S.get (fun ctxt () () -> Alpha_context.global_counter ctxt) let get_global_counter ctxt block = RPC_context.make_call0 S.get ctxt block () @@ -147,6 +146,7 @@ module Liquidity_baking = struct end let register () = + Global_variables.register () ; Contract.register () ; Constants.register () ; Delegate.register () ; diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index 765659b6dfa..4ce2d785dab 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -63,6 +63,8 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = >>=? fun ctxt -> Contract_storage.init ctxt >>=? fun ctxt -> + Storage.Incrementable_global_counter.init ctxt 75l + >>=? fun ctxt -> Bootstrap_storage.init ctxt ~typecheck diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index e87faa71af0..be42cd5dbd4 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -369,11 +369,11 @@ module Encoding = struct { tag = 4; name = "global_counter_increment"; - encoding = obj1 (opt "global_counter_increment" string); + encoding = unit; select = (function | Manager (Global_counter_increment as op) -> Some op | _ -> None); - proj = (function Global_counter_increment -> None); + proj = (function Global_counter_increment -> ()); inj = (fun _ -> Global_counter_increment); } diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 5f73e22ac0e..660bbb29d48 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -82,7 +82,7 @@ module Make_index (H : Storage_description.INDEX) : let args = Storage_description.One {rpc_arg; encoding; compare} end -module Global_counter = +module Incrementable_global_counter = Make_single_data_storage (Registered) (Raw_context) (struct let name = ["global_counter_incrementable"] diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli index c47d53c703c..c66d20ec4ee 100644 --- a/src/proto_alpha/lib_protocol/storage.mli +++ b/src/proto_alpha/lib_protocol/storage.mli @@ -36,7 +36,7 @@ open Storage_sigs -module Global_counter : sig +module Incrementable_global_counter : sig val get : Raw_context.t -> int32 tzresult Lwt.t val update : Raw_context.t -> int32 -> Raw_context.t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml index c7bd5d44965..93053ef8a26 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml @@ -227,7 +227,9 @@ module Alpha_context_helpers = struct >>=? fun (ctx, id) -> let ectx = (Alpha_context.finalize ctx).context in (* bump the level *) - let global_counter = Alpha_context.global_counter ctx in + Alpha_context.global_counter ctx + >>= wrap + >>=? fun global_counter -> Alpha_context.prepare ectx ~level: -- GitLab From d11b66826b9e91ca6a73ad461744092cca092a19 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Thu, 20 May 2021 16:23:11 +0100 Subject: [PATCH 08/33] More debugging --- src/lib_mockup/RPC_client.ml | 1 + src/lib_mockup_proxy/RPC_client.ml | 1 + src/lib_protocol_environment/environment_V2.ml | 8 +++++++- src/lib_rpc/RPC_context.ml | 1 + src/lib_rpc_http/RPC_client.ml | 1 + src/lib_shell_services/chain_services.ml | 1 + src/proto_alpha/lib_client/protocol_client_context.ml | 1 + src/proto_alpha/lib_delegate/logging.ml | 1 + src/proto_alpha/lib_protocol/operation_repr.ml | 6 +++--- 9 files changed, 17 insertions(+), 4 deletions(-) diff --git a/src/lib_mockup/RPC_client.ml b/src/lib_mockup/RPC_client.ml index 1b1df690468..708586241b0 100644 --- a/src/lib_mockup/RPC_client.ml +++ b/src/lib_mockup/RPC_client.ml @@ -47,6 +47,7 @@ class mockup_ctxt (base_dir : string) (mem_only : bool) (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun service params query body -> + let () = print_endline "Mockup call-service" in local_ctxt#call_service service params query body method call_streamed_service diff --git a/src/lib_mockup_proxy/RPC_client.ml b/src/lib_mockup_proxy/RPC_client.ml index f37feeda0d0..3ac66ca4504 100644 --- a/src/lib_mockup_proxy/RPC_client.ml +++ b/src/lib_mockup_proxy/RPC_client.ml @@ -74,6 +74,7 @@ let local_ctxt (directory : unit RPC_directory.t) : RPC_context.json = (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun service params query body -> + let () = print_endline "Joel: still calling service" in C.call_service media_types ~base service params query body method call_streamed_service diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index 128916cc132..056c46924de 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -789,7 +789,9 @@ struct 'o Error_monad.shell_tzresult Lwt.t end - let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s + let make_call0 s (ctxt : _ simple) = + let () = print_endline "Joel: A RPC_context call_proto" in + ctxt#call_proto_service0 s let make_call0 = (make_call0 : _ -> _ simple -> _ :> _ -> _ #simple -> _) @@ -978,8 +980,11 @@ struct 'o ) RPC_service.t -> 'chain * 'block -> 'q -> 'i -> 'o tzresult Lwt.t = fun s (chain, block) q i -> + let () = print_endline "Joel: yep, we're here" in let s = RPC_service.subst0 s in + let () = print_endline "Joel: yep 1" in let s = RPC_service.prefix prefix s in + let () = print_endline "Joel: yep 2" in t#call_service s (((), chain), block) q i method call_proto_service1 @@ -1042,6 +1047,7 @@ struct 'o ) RPC_service.t -> 'block -> 'q -> 'i -> 'o tzresult Lwt.t = fun s block q i -> + let () = print_endline "Joel: in call_proto_service0" in let rpc_context = conv block in lookup#call_service s rpc_context q i diff --git a/src/lib_rpc/RPC_context.ml b/src/lib_rpc/RPC_context.ml index f2061358d89..ad9e58287bc 100644 --- a/src/lib_rpc/RPC_context.ml +++ b/src/lib_rpc/RPC_context.ml @@ -121,6 +121,7 @@ class ['pr] of_directory (dir : 'pr RPC_directory.t) = (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun s p q i -> + let () = print_endline "Joel: method call service" in RPC_directory.transparent_lookup dir s p q i >>= function | `Ok v | `OkChunk v -> diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index f44296496da..f9183bb5204 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -414,6 +414,7 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun service params query body -> + let () = print_endline "Joel: another call service" in call_service media_types ~logger ~base service params query body method call_streamed_service diff --git a/src/lib_shell_services/chain_services.ml b/src/lib_shell_services/chain_services.ml index 4a1a1317860..5f60eaec225 100644 --- a/src/lib_shell_services/chain_services.ml +++ b/src/lib_shell_services/chain_services.ml @@ -180,6 +180,7 @@ module S = struct end let make_call0 s ctxt chain q p = + let () = print_endline "Joel: A make_call0" in let s = RPC_service.prefix path s in RPC_context.make_call1 s ctxt chain q p diff --git a/src/proto_alpha/lib_client/protocol_client_context.ml b/src/proto_alpha/lib_client/protocol_client_context.ml index bc8c51cdccb..7c56340cb64 100644 --- a/src/proto_alpha/lib_client/protocol_client_context.ml +++ b/src/proto_alpha/lib_client/protocol_client_context.ml @@ -57,6 +57,7 @@ class wrap_rpc_context (t : RPC_context.json) : rpc_context = : 'm 'p 'q 'i 'o. (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = + let () = print_endline "Joel: in wrap_rpc_ call_service" in t#call_service method call_streamed_service diff --git a/src/proto_alpha/lib_delegate/logging.ml b/src/proto_alpha/lib_delegate/logging.ml index aaa7172e037..155275e29d0 100644 --- a/src/proto_alpha/lib_delegate/logging.ml +++ b/src/proto_alpha/lib_delegate/logging.ml @@ -76,6 +76,7 @@ let operations_tag = (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations))) let raw_operations_tag = + let () = print_endline "Joel: raw_operation" in Tag.def ~doc:"Raw operations" "raw_operations" (fun fmt raw_ops -> let pp_op fmt op = let json = Data_encoding.Json.construct Operation.raw_encoding op in diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index be42cd5dbd4..56d97df467c 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -367,13 +367,13 @@ module Encoding = struct let[@coq_axiom_with_reason "gadt"] global_counter_increment_case = MCase { - tag = 4; + tag = 47; name = "global_counter_increment"; - encoding = unit; + encoding = obj1 (opt "global_counter_increment" int32); select = (function | Manager (Global_counter_increment as op) -> Some op | _ -> None); - proj = (function Global_counter_increment -> ()); + proj = (function Global_counter_increment -> None); inj = (fun _ -> Global_counter_increment); } -- GitLab From 85e0917ccb833b6111814bb387ecfd0cc3d55101 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Thu, 20 May 2021 17:39:25 +0100 Subject: [PATCH 09/33] Working --- src/lib_rpc_http/RPC_client.ml | 5 ++ .../lib_protocol/alpha_context.mli | 5 ++ src/proto_alpha/lib_protocol/apply_results.ml | 49 +++++++++++++++++-- .../lib_protocol/operation_repr.mli | 5 ++ 4 files changed, 60 insertions(+), 4 deletions(-) diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index f9183bb5204..b05052a3f8f 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -187,6 +187,7 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct | Ok body -> return (f (Some body)) | Error msg -> + let () = print_endline "Joel: handle error" in request_failed meth uri @@ -199,6 +200,7 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct | Some (l, r) -> Cohttp_lwt.Body.to_string body >>= fun body -> + let () = print_endline "Joel: handle error 2" in request_failed meth uri @@ -221,6 +223,7 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct generic_call meth ?headers ~accept:Media_type.[bson; json] ?body ~media uri >>=? function | `Ok (body, (Some ("application", "json") | None), _) -> ( + let () = print_endline "Joel: generic_json_call" in Cohttp_lwt.Body.to_string body >>= fun body -> match Data_encoding.Json.from_string body with @@ -246,6 +249,7 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct (Bytes.unsafe_of_string body) with | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) -> + let () = print_endline "Joel: bson" in let error = Format.asprintf "(at offset: %d) %s" pos msg in request_failed meth @@ -262,6 +266,7 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct | `Ok (body, Some (l, r), _) -> Cohttp_lwt.Body.to_string body >>= fun body -> + let () = print_endline "Joel: other" in request_failed meth uri diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index f67b93c7f45..3a3739f72fd 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1503,6 +1503,9 @@ module Operation : sig val delegation_case : Kind.delegation Kind.manager case + val global_counter_increment_case : + Kind.global_counter_increment Kind.manager case + module Manager_operations : sig type 'b case = | MCase : { @@ -1523,6 +1526,8 @@ module Operation : sig val origination_case : Kind.origination case val delegation_case : Kind.delegation case + + val global_counter_increment_case : Kind.global_counter_increment case end end diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index b2a00fb8bf1..015ca87f0a0 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -395,6 +395,30 @@ module Manager_result = struct ~inj:(fun (consumed_gas, consumed_milligas) -> assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; Delegation_result {consumed_gas = consumed_milligas}) + + let global_counter_increment_case = + make + ~op_case: + Operation.Encoding.Manager_operations.global_counter_increment_case + ~encoding: + Data_encoding.( + obj1 (dft "consumed_gas" Gas.Arith.n_fp_encoding Gas.Arith.zero)) + ~iselect:(function + | Internal_operation_result + (({operation = Global_counter_increment; _} as op), res) -> + Some (op, res) + | _ -> + None) + ~select:(function + | Successful_manager_result (Global_counter_increment_result _ as op) + -> + Some op + | _ -> + None) + ~kind:Kind.Global_counter_increment_kind + ~proj:(function + | Global_counter_increment_result {consumed_gas} -> consumed_gas) + ~inj:(fun consumed_gas -> Global_counter_increment_result {consumed_gas}) end let internal_operation_result_encoding : @@ -428,7 +452,8 @@ let internal_operation_result_encoding : [ make Manager_result.reveal_case; make Manager_result.transaction_case; make Manager_result.origination_case; - make Manager_result.delegation_case ] + make Manager_result.delegation_case; + make Manager_result.global_counter_increment_case ] let successful_manager_operation_result_encoding : packed_successful_manager_operation_result Data_encoding.t = @@ -454,7 +479,8 @@ let successful_manager_operation_result_encoding : [ make Manager_result.reveal_case; make Manager_result.transaction_case; make Manager_result.origination_case; - make Manager_result.delegation_case ] + make Manager_result.delegation_case; + make Manager_result.global_counter_increment_case ] type 'kind contents_result = | Endorsement_result : { @@ -861,6 +887,19 @@ module Encoding = struct Some (op, res) | _ -> None) + + let[@coq_axiom_with_reason "gadt"] global_counter_increment_case = + make_manager_case + Operation.Encoding.global_counter_increment_case + Manager_result.global_counter_increment_case + (function + | Contents_and_result + ( ( Manager_operation {operation = Global_counter_increment; _} as + op ), + res ) -> + Some (op, res) + | _ -> + None) end let contents_result_encoding = @@ -892,7 +931,8 @@ let contents_result_encoding = make reveal_case; make transaction_case; make origination_case; - make delegation_case ] + make delegation_case; + make global_counter_increment_case ] let contents_and_result_encoding = let open Encoding in @@ -928,7 +968,8 @@ let contents_and_result_encoding = make reveal_case; make transaction_case; make origination_case; - make delegation_case ] + make delegation_case; + make global_counter_increment_case ] type 'kind contents_result_list = | Single_result : 'kind contents_result -> 'kind contents_result_list diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index e4f6f1591a6..65d3746ab72 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -262,6 +262,9 @@ module Encoding : sig val delegation_case : Kind.delegation Kind.manager case + val global_counter_increment_case : + Kind.global_counter_increment Kind.manager case + module Manager_operations : sig type 'b case = | MCase : { @@ -281,5 +284,7 @@ module Encoding : sig val origination_case : Kind.origination case val delegation_case : Kind.delegation case + + val global_counter_increment_case : Kind.global_counter_increment case end end -- GitLab From 6d22d452c02831323c1dacae2da08a09add37778 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Thu, 20 May 2021 17:48:46 +0100 Subject: [PATCH 10/33] Remove debug --- src/lib_mockup/RPC_client.ml | 1 - src/lib_mockup_proxy/RPC_client.ml | 1 - .../environment_V2.ml | 8 +---- src/lib_rpc/RPC_context.ml | 1 - src/lib_rpc_http/RPC_client.ml | 6 ---- src/lib_shell_services/chain_services.ml | 1 - .../lib_client/client_proto_context.ml | 6 ---- src/proto_alpha/lib_client/injection.ml | 35 ++----------------- .../lib_client/protocol_client_context.ml | 1 - .../client_proto_context_commands.ml | 2 -- src/proto_alpha/lib_delegate/logging.ml | 1 - src/proto_alpha/lib_plugin/plugin.ml | 1 - src/proto_alpha/lib_protocol/main.ml | 3 -- src/proto_alpha/lib_protocol/raw_context.ml | 1 - 14 files changed, 3 insertions(+), 65 deletions(-) diff --git a/src/lib_mockup/RPC_client.ml b/src/lib_mockup/RPC_client.ml index 708586241b0..1b1df690468 100644 --- a/src/lib_mockup/RPC_client.ml +++ b/src/lib_mockup/RPC_client.ml @@ -47,7 +47,6 @@ class mockup_ctxt (base_dir : string) (mem_only : bool) (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun service params query body -> - let () = print_endline "Mockup call-service" in local_ctxt#call_service service params query body method call_streamed_service diff --git a/src/lib_mockup_proxy/RPC_client.ml b/src/lib_mockup_proxy/RPC_client.ml index 3ac66ca4504..f37feeda0d0 100644 --- a/src/lib_mockup_proxy/RPC_client.ml +++ b/src/lib_mockup_proxy/RPC_client.ml @@ -74,7 +74,6 @@ let local_ctxt (directory : unit RPC_directory.t) : RPC_context.json = (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun service params query body -> - let () = print_endline "Joel: still calling service" in C.call_service media_types ~base service params query body method call_streamed_service diff --git a/src/lib_protocol_environment/environment_V2.ml b/src/lib_protocol_environment/environment_V2.ml index 056c46924de..128916cc132 100644 --- a/src/lib_protocol_environment/environment_V2.ml +++ b/src/lib_protocol_environment/environment_V2.ml @@ -789,9 +789,7 @@ struct 'o Error_monad.shell_tzresult Lwt.t end - let make_call0 s (ctxt : _ simple) = - let () = print_endline "Joel: A RPC_context call_proto" in - ctxt#call_proto_service0 s + let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s let make_call0 = (make_call0 : _ -> _ simple -> _ :> _ -> _ #simple -> _) @@ -980,11 +978,8 @@ struct 'o ) RPC_service.t -> 'chain * 'block -> 'q -> 'i -> 'o tzresult Lwt.t = fun s (chain, block) q i -> - let () = print_endline "Joel: yep, we're here" in let s = RPC_service.subst0 s in - let () = print_endline "Joel: yep 1" in let s = RPC_service.prefix prefix s in - let () = print_endline "Joel: yep 2" in t#call_service s (((), chain), block) q i method call_proto_service1 @@ -1047,7 +1042,6 @@ struct 'o ) RPC_service.t -> 'block -> 'q -> 'i -> 'o tzresult Lwt.t = fun s block q i -> - let () = print_endline "Joel: in call_proto_service0" in let rpc_context = conv block in lookup#call_service s rpc_context q i diff --git a/src/lib_rpc/RPC_context.ml b/src/lib_rpc/RPC_context.ml index ad9e58287bc..f2061358d89 100644 --- a/src/lib_rpc/RPC_context.ml +++ b/src/lib_rpc/RPC_context.ml @@ -121,7 +121,6 @@ class ['pr] of_directory (dir : 'pr RPC_directory.t) = (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun s p q i -> - let () = print_endline "Joel: method call service" in RPC_directory.transparent_lookup dir s p q i >>= function | `Ok v | `OkChunk v -> diff --git a/src/lib_rpc_http/RPC_client.ml b/src/lib_rpc_http/RPC_client.ml index b05052a3f8f..f44296496da 100644 --- a/src/lib_rpc_http/RPC_client.ml +++ b/src/lib_rpc_http/RPC_client.ml @@ -187,7 +187,6 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct | Ok body -> return (f (Some body)) | Error msg -> - let () = print_endline "Joel: handle error" in request_failed meth uri @@ -200,7 +199,6 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct | Some (l, r) -> Cohttp_lwt.Body.to_string body >>= fun body -> - let () = print_endline "Joel: handle error 2" in request_failed meth uri @@ -223,7 +221,6 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct generic_call meth ?headers ~accept:Media_type.[bson; json] ?body ~media uri >>=? function | `Ok (body, (Some ("application", "json") | None), _) -> ( - let () = print_endline "Joel: generic_json_call" in Cohttp_lwt.Body.to_string body >>= fun body -> match Data_encoding.Json.from_string body with @@ -249,7 +246,6 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct (Bytes.unsafe_of_string body) with | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) -> - let () = print_endline "Joel: bson" in let error = Format.asprintf "(at offset: %d) %s" pos msg in request_failed meth @@ -266,7 +262,6 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct | `Ok (body, Some (l, r), _) -> Cohttp_lwt.Body.to_string body >>= fun body -> - let () = print_endline "Joel: other" in request_failed meth uri @@ -419,7 +414,6 @@ module Make (Client : Resto_cohttp_client.Client.CALL) = struct (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = fun service params query body -> - let () = print_endline "Joel: another call service" in call_service media_types ~logger ~base service params query body method call_streamed_service diff --git a/src/lib_shell_services/chain_services.ml b/src/lib_shell_services/chain_services.ml index 5f60eaec225..4a1a1317860 100644 --- a/src/lib_shell_services/chain_services.ml +++ b/src/lib_shell_services/chain_services.ml @@ -180,7 +180,6 @@ module S = struct end let make_call0 s ctxt chain q p = - let () = print_endline "Joel: A make_call0" in let s = RPC_service.prefix path s in RPC_context.make_call1 s ctxt chain q p diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 501d1eeab95..5425e619c20 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -159,7 +159,6 @@ let build_incremenent_global_counter_operation ?fee ?gas_limit ?storage_limit let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch ~source ~src_pk ~src_sk ?fee ?gas_limit ?storage_limit ?counter ~fee_parameter () = - let () = print_endline "Joel: Build inc conter op" in let contents = build_incremenent_global_counter_operation ?fee @@ -167,9 +166,7 @@ let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ?storage_limit () in - let () = print_endline "Joel: Create contents" in let contents = Annotated_manager_operation.Single_manager contents in - let () = print_endline "Joel: Inject manager operation " in Injection.inject_manager_operation cctxt ~chain @@ -188,13 +185,10 @@ let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ~fee_parameter contents >>=? fun (oph, op, result) -> - let () = print_endline "Joel: Inject originated contracts" in Lwt.return (Injection.originated_contracts result) >>=? fun contracts -> - let () = print_endline "Joel: Contracts should be empty" in match Apply_results.pack_contents_list op result with | Apply_results.Single_and_result ((Manager_operation _ as op), result) -> - let () = print_endline "Joel: Return operation hash etc" in return ((oph, op, result), contracts) let build_reveal_operation ?fee ?gas_limit ?storage_limit pk = diff --git a/src/proto_alpha/lib_client/injection.ml b/src/proto_alpha/lib_client/injection.ml index 114d56f3f73..8ae29673669 100644 --- a/src/proto_alpha/lib_client/injection.ml +++ b/src/proto_alpha/lib_client/injection.ml @@ -296,18 +296,14 @@ let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block ?branch (contents : t contents_list) = - let () = print_endline "Joel: 1 get_branch" in get_branch cctxt ~chain ~block branch >>=? fun (_chain_id, branch) -> - let () = print_endline "Joel: 2 get hash" in let op : _ Operation.t = {shell = {branch}; protocol_data = {contents; signature = None}} in let oph = Operation.hash op in - let () = print_endline "Joel: got the hash" in Chain_services.chain_id cctxt ~chain () >>=? fun chain_id -> - let () = print_endline "Joel: 3 run_operation" in Plugin.RPC.Scripts.run_operation cctxt (chain, block) @@ -422,7 +418,6 @@ let originated_contracts_single (type kind) | Applied (Delegation_result _) -> Ok [] | Applied (Global_counter_increment_result _) -> - (* TODO: JOEL not sure about this*) Ok [] | Skipped _ -> assert false @@ -503,10 +498,8 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) ~fee_parameter ~chain ~block ?branch (annotated_contents : kind Annotated_manager_operation.annotated_list) : kind Kind.manager contents_list tzresult Lwt.t = - let () = print_endline "Joel: wait_for_bootstrapped" in Tezos_client_base.Client_confirmations.wait_for_bootstrapped cctxt >>=? fun () -> - let () = print_endline "Joel: 1" in Alpha_services.Constants.all cctxt (chain, block) >>=? fun { parametric = { hard_gas_limit_per_operation; @@ -515,7 +508,6 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) cost_per_byte; _ }; _ } -> - let () = print_endline "Joel: 2" in let user_gas_limit_needs_patching user_gas_limit = Limit.fold user_gas_limit ~unknown:true ~known:(fun user_gas_limit -> Gas.Arith.( @@ -704,51 +696,41 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fun first annotated_list result_list -> match (annotated_list, result_list) with | (Single_manager annotated, Single_result res) -> - let () = print_endline "Joel: A" in patch ~first (annotated, res) >>=? fun op -> return (Single op) | (Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest)) -> - let () = print_endline "Joel: B" in patch ~first (annotated, res) >>=? fun op -> patch_list false annotated_rest res_rest >>=? fun rest -> return (Cons (op, rest)) | _ -> - let () = print_endline "Joel: C (assert false)" in assert false in match may_need_patching annotated_contents with | Some annotated_for_simulation -> - let () = print_endline "Joel: 3 May need patching" in Lwt.return (Annotated_manager_operation.manager_list_from_annotated annotated_for_simulation) >>=? fun contents_for_simulation -> - let () = print_endline "Joel: 4 simulate:" in simulate cctxt ~chain ~block ?branch contents_for_simulation >>=? fun (_, _, result) -> ( match detect_script_failure result with | Ok () -> - let () = print_endline "Joel: ok" in return_unit | Error _ -> - let () = print_endline "Joel: simulation failed:" in cctxt#message "@[This simulation failed:@,%a@]" Operation_result.pp_operation_result (contents_for_simulation, result.contents) >>= fun () -> return_unit ) >>=? fun () -> - let () = print_endline "Joel: return" in Lwt.return (estimated_storage (Z.of_int origination_size) result.contents) >>=? (fun storage -> - let () = print_endline "Joel: got storage" in Lwt.return (Environment.wrap_tzresult Tez.(cost_per_byte *? Z.to_int64 storage)) >>=? fun burn -> - let () = print_endline "Joel: burn storage" in if Tez.(burn > fee_parameter.burn_cap) then cctxt#error "The operation will burn %s%a which is higher than the \ @@ -762,15 +744,10 @@ let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full) fee_parameter.burn_cap Tez.pp burn - >>= fun () -> - let () = print_endline "Joel: exit" in - exit 1 + >>= fun () -> exit 1 else return_unit) - >>=? fun () -> - let () = print_endline "Joel: patch list " in - patch_list true annotated_contents result.contents + >>=? fun () -> patch_list true annotated_contents result.contents | None -> - let () = print_endline "Joel: 4 No patching" in Lwt.return (Annotated_manager_operation.manager_list_from_annotated annotated_contents) @@ -801,7 +778,6 @@ let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations >>= fun () -> Lwt.return res ) >>=? fun () -> let bytes = - let () = print_endline "Call `to_bytes_exn`" in Data_encoding.Binary.to_bytes_exn Operation.encoding (Operation.pack op) in if dry_run || simulation then @@ -959,10 +935,8 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations | Some counter -> return counter ) >>=? fun counter -> - let () = print_endline "Joel: manager_key" in Alpha_services.Contract.manager_key cctxt (chain, block) source >>=? fun key -> - let () = print_endline "Joel: got key" in (* [has_reveal] assumes that a Reveal operation only appears as the first of a batch *) let has_reveal : type kind. kind Annotated_manager_operation.annotated_list -> bool = @@ -1002,7 +976,6 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations in match key with | None when not (has_reveal operations) -> ( - let () = print_endline "Joel: None key" in ( if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then reveal_error cctxt else return_unit ) @@ -1043,16 +1016,12 @@ let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations | _ -> assert false ) | Some _ when has_reveal operations -> - let () = print_endline "Joel: some fail" in failwith "The manager key was previously revealed." | _ -> - let () = print_endline "Joel: other - build_contents" in build_contents counter operations >>?= fun contents -> - let () = print_endline "Joel: my_patch" in may_patch_limits cctxt ~fee_parameter ~chain ~block ?branch contents >>=? fun contents -> - let () = print_endline "Joel: inject_operation_internal" in inject_operation_internal cctxt ~chain diff --git a/src/proto_alpha/lib_client/protocol_client_context.ml b/src/proto_alpha/lib_client/protocol_client_context.ml index 7c56340cb64..bc8c51cdccb 100644 --- a/src/proto_alpha/lib_client/protocol_client_context.ml +++ b/src/proto_alpha/lib_client/protocol_client_context.ml @@ -57,7 +57,6 @@ class wrap_rpc_context (t : RPC_context.json) : rpc_context = : 'm 'p 'q 'i 'o. (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p -> 'q -> 'i -> 'o tzresult Lwt.t = - let () = print_endline "Joel: in wrap_rpc_ call_service" in t#call_service method call_streamed_service diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 9064c806e2d..c7572560b53 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -148,7 +148,6 @@ let increment_global_counter_command source cctxt Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> return (src_pk, src_sk, source) ) >>=? fun (src_pk, src_sk, source) -> - let () = print_endline "Call increment_global_counter" in Client_proto_context.increment_global_counter cctxt ~chain:cctxt#chain @@ -319,7 +318,6 @@ let prepare_batch_operation cctxt ?arg ?fee ?gas_limit ?storage_limit return (Annotated_manager_operation.Annotated_manager_operation operation) let commands network () = - let () = print_endline "Joel debug: Alpha-protocol running" in let open Clic in [ command ~group diff --git a/src/proto_alpha/lib_delegate/logging.ml b/src/proto_alpha/lib_delegate/logging.ml index 155275e29d0..aaa7172e037 100644 --- a/src/proto_alpha/lib_delegate/logging.ml +++ b/src/proto_alpha/lib_delegate/logging.ml @@ -76,7 +76,6 @@ let operations_tag = (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations))) let raw_operations_tag = - let () = print_endline "Joel: raw_operation" in Tag.def ~doc:"Raw operations" "raw_operations" (fun fmt raw_ops -> let pp_op fmt op = let json = Data_encoding.Json.construct Operation.raw_encoding op in diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 511231d9522..b9c08b88fb5 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1298,7 +1298,6 @@ module RPC = struct RPC_context.make_call0 S.normalize_type ctxt block () ty let run_operation ctxt block ~op ~chain_id = - let () = print_endline "Joel: make_call0" in RPC_context.make_call0 S.run_operation ctxt block () (op, chain_id) let entrypoint_type ctxt block ~script ~entrypoint = diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index f5ecc04887d..d879b5d6c26 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -123,7 +123,6 @@ let begin_partial_application ~chain_id ~ancestor_context:ctxt let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - (* TODO: Joel fetch *) let global_counter = 39l in Alpha_context.prepare ~level @@ -160,7 +159,6 @@ let begin_application ~chain_id ~predecessor_context:ctxt let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - (* TODO: Joel fetch - perhaps pass as bytes? *) let global_counter = 40l in Alpha_context.prepare ~level @@ -197,7 +195,6 @@ let begin_construction ~chain_id ~predecessor_context:ctxt ?(protocol_data : block_header_data option) () = let level = Int32.succ pred_level in let fitness = pred_fitness in - (* TODO: Joel pass as bytes? *) let global_counter = 41l in Alpha_context.prepare ~level diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index f051bd4682d..aae6345bba3 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -927,7 +927,6 @@ let prepare_first_block ~level ~timestamp ~fitness ctxt = Level_repr.create_cycle_eras [second_cycle_era; first_cycle_era] >>?= fun cycle_eras -> set_cycle_eras ctxt cycle_eras ) >>=? fun ctxt -> - (* TODO: Joel to dig out*) let global_counter = 38l in prepare ctxt -- GitLab From c159af264d8e657a93f2cfa9c6a0a8b8d03b4f4c Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Thu, 20 May 2021 18:01:57 +0100 Subject: [PATCH 11/33] Remove global-counter from raw context --- .../lib_protocol/alpha_context.mli | 1 - src/proto_alpha/lib_protocol/init_storage.ml | 13 +++------ src/proto_alpha/lib_protocol/init_storage.mli | 1 - src/proto_alpha/lib_protocol/main.ml | 27 +++---------------- src/proto_alpha/lib_protocol/raw_context.ml | 22 ++------------- src/proto_alpha/lib_protocol/raw_context.mli | 6 ----- .../lib_protocol/services_registration.ml | 3 --- .../test/helpers/sapling_helpers.ml | 7 ----- .../lib_protocol/test/test_baking.ml | 1 - .../lib_protocol/test/test_gas_levels.ml | 1 - .../lib_protocol/test/test_rolls.ml | 2 -- .../lib_protocol/test/test_sapling.ml | 9 ------- .../lib_protocol/test/test_temp_big_maps.ml | 1 - 13 files changed, 8 insertions(+), 86 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 3a3739f72fd..f670aa548e7 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1614,7 +1614,6 @@ val prepare : predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> - global_counter:int32 -> (context * Receipt.balance_updates * Migration.origination_result list) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index 4ce2d785dab..ebdbd9d6b7c 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -63,7 +63,7 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = >>=? fun ctxt -> Contract_storage.init ctxt >>=? fun ctxt -> - Storage.Incrementable_global_counter.init ctxt 75l + Storage.Incrementable_global_counter.init ctxt 0l >>=? fun ctxt -> Bootstrap_storage.init ctxt @@ -120,13 +120,6 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness = >>=? fun (ctxt, operation_results) -> Storage.Pending_migration.Operation_results.init ctxt operation_results -let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness - ~global_counter = - Raw_context.prepare - ~level - ~predecessor_timestamp - ~timestamp - ~fitness - ~global_counter - ctxt +let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness = + Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun ctxt -> Storage.Pending_migration.remove ctxt diff --git a/src/proto_alpha/lib_protocol/init_storage.mli b/src/proto_alpha/lib_protocol/init_storage.mli index f5c0f7e6f7f..14cd0ed5f9d 100644 --- a/src/proto_alpha/lib_protocol/init_storage.mli +++ b/src/proto_alpha/lib_protocol/init_storage.mli @@ -43,7 +43,6 @@ val prepare : predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> - global_counter:int32 -> ( Raw_context.t * Receipt_repr.balance_updates * Migration_repr.origination_result list ) diff --git a/src/proto_alpha/lib_protocol/main.ml b/src/proto_alpha/lib_protocol/main.ml index d879b5d6c26..d6cbf7b217e 100644 --- a/src/proto_alpha/lib_protocol/main.ml +++ b/src/proto_alpha/lib_protocol/main.ml @@ -123,14 +123,7 @@ let begin_partial_application ~chain_id ~ancestor_context:ctxt let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - let global_counter = 39l in - Alpha_context.prepare - ~level - ~predecessor_timestamp - ~timestamp - ~fitness - ~global_counter - ctxt + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun (ctxt, migration_balance_updates, migration_operation_results) -> Apply.begin_application ctxt chain_id block_header predecessor_timestamp >|=? fun ( ctxt, @@ -159,14 +152,7 @@ let begin_application ~chain_id ~predecessor_context:ctxt let level = block_header.shell.level in let fitness = predecessor_fitness in let timestamp = block_header.shell.timestamp in - let global_counter = 40l in - Alpha_context.prepare - ~level - ~predecessor_timestamp - ~timestamp - ~fitness - ~global_counter - ctxt + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun (ctxt, migration_balance_updates, migration_operation_results) -> Apply.begin_application ctxt chain_id block_header predecessor_timestamp >|=? fun ( ctxt, @@ -195,14 +181,7 @@ let begin_construction ~chain_id ~predecessor_context:ctxt ?(protocol_data : block_header_data option) () = let level = Int32.succ pred_level in let fitness = pred_fitness in - let global_counter = 41l in - Alpha_context.prepare - ~level - ~predecessor_timestamp - ~timestamp - ~fitness - ~global_counter - ctxt + Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt >>=? fun (ctxt, migration_balance_updates, migration_operation_results) -> ( match protocol_data with | None -> diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index aae6345bba3..a926957b16d 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -76,7 +76,6 @@ type back = { internal_nonces_used : Int_set.t; remaining_block_gas : Gas_limit_repr.Arith.fp; unlimited_operation_gas : bool; - global_counter : int32; } (* @@ -113,8 +112,6 @@ let[@inline] current_fitness ctxt = ctxt.back.fitness let[@inline] cycle_eras ctxt = ctxt.back.cycle_eras -let[@inline] global_counter ctxt = ctxt.back.global_counter - let[@inline] constants ctxt = ctxt.back.constants let[@inline] recover ctxt = ctxt.back.context @@ -199,12 +196,6 @@ let[@inline] update_temporary_lazy_storage_ids ctxt temporary_lazy_storage_ids = update_back ctxt {ctxt.back with temporary_lazy_storage_ids} -let[@inline] update_global_counter ctxt global_counter = - update_back ctxt {ctxt.back with global_counter} - -let[@inline] increment_global_counter ctxt = - update_global_counter ctxt (Int32.add (global_counter ctxt) 1l) - let record_endorsement ctxt k = match Signature.Public_key_hash.Map.find_opt k (allowed_endorsements ctxt) @@ -709,8 +700,7 @@ let check_cycle_eras (cycle_eras : Level_repr.cycle_eras) Compare.Int32.( current_era.blocks_per_commitment = constants.blocks_per_commitment) ) -let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ~global_counter - ctxt = +let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt = Raw_level_repr.of_int32 level >>?= fun level -> Fitness_repr.to_int64 fitness @@ -749,7 +739,6 @@ let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ~global_counter Gas_limit_repr.Arith.fp constants.Constants_repr.hard_gas_limit_per_block; unlimited_operation_gas = true; - global_counter; }; } @@ -927,14 +916,7 @@ let prepare_first_block ~level ~timestamp ~fitness ctxt = Level_repr.create_cycle_eras [second_cycle_era; first_cycle_era] >>?= fun cycle_eras -> set_cycle_eras ctxt cycle_eras ) >>=? fun ctxt -> - let global_counter = 38l in - prepare - ctxt - ~level - ~predecessor_timestamp:timestamp - ~timestamp - ~fitness - ~global_counter + prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness >|=? fun ctxt -> (previous_proto, ctxt) let activate ctxt h = Updater.activate (context ctxt) h >|= update_context ctxt diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index d690ac5091e..6cd245f918b 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -61,7 +61,6 @@ val prepare : predecessor_timestamp:Time.t -> timestamp:Time.t -> fitness:Fitness.t -> - global_counter:int32 -> Context.t -> t tzresult Lwt.t @@ -98,9 +97,6 @@ val patch_constants : (** Retrieve the cycle eras. *) val cycle_eras : t -> Level_repr.cycle_eras -(** Retrieve the global-counter. *) -val global_counter : t -> int32 - (** Increment the current block fee stash that will be credited to baker's frozen_fees account at finalize_application *) val add_fees : t -> Tez_repr.t -> t tzresult @@ -149,8 +145,6 @@ val update_storage_space_to_pay : t -> Z.t -> t val update_allocated_contracts_count : t -> t -val increment_global_counter : t -> t - val clear_storage_space_to_pay : t -> t * Z.t * int type error += Undefined_operation_nonce (* `Permanent *) diff --git a/src/proto_alpha/lib_protocol/services_registration.ml b/src/proto_alpha/lib_protocol/services_registration.ml index 323fafef9d6..95330034977 100644 --- a/src/proto_alpha/lib_protocol/services_registration.ml +++ b/src/proto_alpha/lib_protocol/services_registration.ml @@ -35,14 +35,11 @@ let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) = let level = block_header.level in let timestamp = block_header.timestamp in let fitness = block_header.fitness in - (* TODO: Joel, dig out from context? *) - let global_counter = 42l in Alpha_context.prepare ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness - ~global_counter context >|=? fun (context, _, _) -> {block_hash; block_header; context} diff --git a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml index 93053ef8a26..b6e5a0a2f8d 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sapling_helpers.ml @@ -153,15 +153,12 @@ module Alpha_context_helpers = struct let init () = Context.init 1 >>=? fun (b, _) -> - (* TODO: Joel dig this from context? *) - let global_counter = 43l in Alpha_context.prepare b.context ~level:b.header.shell.level ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter >>= wrap >|=? fun (ctxt, _, _) -> ctxt @@ -227,9 +224,6 @@ module Alpha_context_helpers = struct >>=? fun (ctx, id) -> let ectx = (Alpha_context.finalize ctx).context in (* bump the level *) - Alpha_context.global_counter ctx - >>= wrap - >>=? fun global_counter -> Alpha_context.prepare ectx ~level: @@ -238,7 +232,6 @@ module Alpha_context_helpers = struct ~predecessor_timestamp:(Time.Protocol.of_seconds Int64.zero) ~timestamp:(Time.Protocol.of_seconds Int64.zero) ~fitness:(Fitness_repr.from_int64 Int64.zero) - ~global_counter >>= wrap >|=? fun (ctx, _, _) -> Some (ctx, id) diff --git a/src/proto_alpha/lib_protocol/test/test_baking.ml b/src/proto_alpha/lib_protocol/test/test_baking.ml index 5eac2ced198..a629ffc203d 100644 --- a/src/proto_alpha/lib_protocol/test/test_baking.ml +++ b/src/proto_alpha/lib_protocol/test/test_baking.ml @@ -230,7 +230,6 @@ let test_rewards_formulas_equivalence () = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun (ctxt, _, _) -> let block_priorities = 0 -- 64 in diff --git a/src/proto_alpha/lib_protocol/test/test_gas_levels.ml b/src/proto_alpha/lib_protocol/test/test_gas_levels.ml index 4f7f2345a63..90b22f9a438 100644 --- a/src/proto_alpha/lib_protocol/test/test_gas_levels.ml +++ b/src/proto_alpha/lib_protocol/test/test_gas_levels.ml @@ -54,7 +54,6 @@ let dummy_context () = ~predecessor_timestamp:Time.Protocol.epoch ~timestamp:Time.Protocol.epoch ~fitness:[] - ~global_counter:0l (block.context : Environment_context.Context.t) >|= Environment.wrap_tzresult diff --git a/src/proto_alpha/lib_protocol/test/test_rolls.ml b/src/proto_alpha/lib_protocol/test/test_rolls.ml index 5da8a11ab36..dd2af08f874 100644 --- a/src/proto_alpha/lib_protocol/test/test_rolls.ml +++ b/src/proto_alpha/lib_protocol/test/test_rolls.ml @@ -66,7 +66,6 @@ let check_rolls (b : Block.t) (account : Account.t) = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctxt -> Roll_storage.count_rolls ctxt account.pkh @@ -81,7 +80,6 @@ let check_no_rolls (b : Block.t) (account : Account.t) = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctxt -> Roll_storage.count_rolls ctxt account.pkh diff --git a/src/proto_alpha/lib_protocol/test/test_sapling.ml b/src/proto_alpha/lib_protocol/test/test_sapling.ml index 785cfb41c77..64b88d2151e 100644 --- a/src/proto_alpha/lib_protocol/test/test_sapling.ml +++ b/src/proto_alpha/lib_protocol/test/test_sapling.ml @@ -48,7 +48,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctx -> let module H = Tezos_sapling.Core.Client.Hash in @@ -97,7 +96,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -136,7 +134,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -212,7 +209,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -270,7 +266,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -359,7 +354,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -384,7 +378,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l (Raw_context.recover ctx) >>= wrap >|=? fun ctx -> (ctx, Int32.succ cnt)) @@ -440,7 +433,6 @@ module Raw_context_tests = struct ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun ctx -> Lazy_storage_diff.fresh @@ -1044,7 +1036,6 @@ module Interpreter_tests = struct ~predecessor_timestamp:block.header.shell.timestamp ~timestamp:block.header.shell.timestamp ~fitness:block.header.shell.fitness - ~global_counter:0l >>= wrap >>=? fun raw_ctx -> Sapling_storage.Roots.mem raw_ctx id root >>= wrap in diff --git a/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml b/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml index 512a5cf2788..d6b12436ddc 100644 --- a/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml +++ b/src/proto_alpha/lib_protocol/test/test_temp_big_maps.ml @@ -39,7 +39,6 @@ let to_raw_context (b : Block.t) = ~predecessor_timestamp:b.header.shell.timestamp ~timestamp:b.header.shell.timestamp ~fitness:b.header.shell.fitness - ~global_counter:0l >|= Environment.wrap_tzresult let check_no_dangling_temp_big_map b = -- GitLab From e46d2b7d3bda8e96eb2d859058916259392f4ff7 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Thu, 20 May 2021 18:12:48 +0100 Subject: [PATCH 12/33] Simplify encodign --- src/proto_alpha/lib_protocol/operation_repr.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 56d97df467c..be42cd5dbd4 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -367,13 +367,13 @@ module Encoding = struct let[@coq_axiom_with_reason "gadt"] global_counter_increment_case = MCase { - tag = 47; + tag = 4; name = "global_counter_increment"; - encoding = obj1 (opt "global_counter_increment" int32); + encoding = unit; select = (function | Manager (Global_counter_increment as op) -> Some op | _ -> None); - proj = (function Global_counter_increment -> None); + proj = (function Global_counter_increment -> ()); inj = (fun _ -> Global_counter_increment); } -- GitLab From 36fe59ef7b5e75e8172d6509f0fa6dd14444b354 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Fri, 21 May 2021 09:09:46 +0100 Subject: [PATCH 13/33] Recover storage command --- .../client_proto_context_commands.ml | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index c7572560b53..7ab6409bfea 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -367,6 +367,26 @@ let commands network () = (fun () (cctxt : Protocol_client_context.full) -> get_global_counter cctxt ~chain:cctxt#chain ~block:cctxt#block >>=? fun count -> cctxt#answer "%ld" count >>= fun () -> return_unit); + command + ~group + ~desc:"Get the storage of a contract." + (args1 (unparsing_mode_arg ~default:"Readable")) + ( prefixes ["get"; "contract"; "storage"; "for"] + @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" + @@ stop ) + (fun unparsing_mode (_, contract) (cctxt : Protocol_client_context.full) -> + get_storage + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~unparsing_mode + contract + >>=? function + | None -> + cctxt#error "This is not a smart contract." + | Some storage -> + cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage + >>= fun () -> return_unit); command ~group ~desc: -- GitLab From 083a3efff47193a854d4b32a62e29dbb4c15f1a0 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Fri, 21 May 2021 16:14:34 +0100 Subject: [PATCH 14/33] Michelson instruction for increment counter --- .../lib_protocol/alpha_context.mli | 2 + .../lib_protocol/michelson_v1_gas.ml | 39 + .../lib_protocol/michelson_v1_gas.mli | 2 + .../lib_protocol/michelson_v1_primitives.ml | 18 +- .../lib_protocol/michelson_v1_primitives.mli | 2 + .../lib_protocol/script_interpreter.ml | 1223 +++++++++++------ .../lib_protocol/script_ir_translator.ml | 31 +- .../lib_protocol/script_typed_ir.ml | 5 +- 8 files changed, 915 insertions(+), 407 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index f670aa548e7..fdcc330e625 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -400,6 +400,8 @@ module Script : sig | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS + | I_GLOBAL_COUNTER + | I_INCREMENT_GLOBAL_COUNTER | T_bool | T_contract | T_int diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index f65d2fc1a95..bb7b832b988 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -1368,6 +1368,8 @@ module Cost_of = struct (int_bytes ticket_a.amount) (int_bytes ticket_b.amount)) + let increment_global_counter = atomic_step_cost cost_N_IIncrement_global_counter_key + (* Continuations *) module Control = struct let nil = atomic_step_cost cost_N_KNil @@ -1582,6 +1584,43 @@ module Cost_of = struct atomic_step_cost S.(add (S.safe_int 100) (S.ediv total_bytes (S.safe_int 10))) + (* Cost of additional call to logger + overhead of setting up call to [interp]. *) + let exec = atomic_step_cost (S.safe_int 100) + + (* Heavy computation happens in the [unparse_data], [unparse_ty] + functions which are carbonated. We must account for allocating + the Micheline lambda wrapper. *) + let apply = atomic_step_cost (S.safe_int 1000) + + (* Pushing a pointer on the stack. *) + let lambda = push + + (* Pusing an address on the stack. *) + let address = push + + (* Most computation happens in [parse_contract_from_script], which is carbonated. + Account for pushing on the stack. *) + let contract = push + + (* Most computation happens in [collect_lazy_storage], [extract_lazy_storage_diff] + and [unparse_data] which are carbonated. The instruction-specific overhead + is mostly that of updating the internal nonce, which we approximate by the + cost of a push. *) + let transfer_tokens = Gas.(push +@ push) + + (* TODO: Joel: what should be the gas cost? *) + let increment_global_counter = Gas.(push) + + (* Wrapping a value and pushing it on the stack. *) + let implicit_account = push + + (* As for [transfer_token], most computation happens elsewhere. + We still account for the overhead of updating the internal_nonce. *) + let create_contract = Gas.(push +@ push) + + (* Increments the internal_nonce counter. *) + let set_delegate = Gas.(push +@ push) + (* Cost of access taken care of in Contract_storage.get_balance_carbonated *) let balance = Gas.free diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli index 30ef4ff903e..fda705fb803 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli @@ -344,6 +344,8 @@ module Cost_of : sig val transfer_tokens : Gas.cost + val increment_global_counter : Gas.cost + val implicit_account : Gas.cost val create_contract : Gas.cost diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 2231590b94c..0994c1c3ffa 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -146,6 +146,8 @@ type prim = | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS + | I_GLOBAL_COUNTER + | I_INCREMENT_GLOBAL_COUNTER | T_bool | T_contract | T_int @@ -296,7 +298,9 @@ let namespace = function | I_UNPAIR | I_UPDATE | I_VOTING_POWER - | I_XOR -> + | I_XOR + | I_GLOBAL_COUNTER + | I_INCREMENT_GLOBAL_COUNTER -> Instr_namespace | T_address | T_big_map @@ -567,6 +571,10 @@ let string_of_prim = function "SPLIT_TICKET" | I_JOIN_TICKETS -> "JOIN_TICKETS" + | I_GLOBAL_COUNTER -> + "GLOBAL_COUNTER" + | I_INCREMENT_GLOBAL_COUNTER -> + "INCREMENT_GLOBAL_COUNTER" | T_bool -> "bool" | T_contract -> @@ -851,6 +859,10 @@ let prim_of_string = function ok I_SPLIT_TICKET | "JOIN_TICKETS" -> ok I_JOIN_TICKETS + | "GLOBAL_COUNTER" -> + ok I_GLOBAL_COUNTER + | "INCREMENT_GLOBAL_COUNTER" -> + ok I_INCREMENT_GLOBAL_COUNTER | "bool" -> ok T_bool | "contract" -> @@ -1113,7 +1125,9 @@ let prim_encoding = ("READ_TICKET", I_READ_TICKET); ("SPLIT_TICKET", I_SPLIT_TICKET); ("JOIN_TICKETS", I_JOIN_TICKETS); - ("GET_AND_UPDATE", I_GET_AND_UPDATE) + ("GET_AND_UPDATE", I_GET_AND_UPDATE); + ("GLOBAL_COUNTER", I_GLOBAL_COUNTER); + ("INCREMENT_GLOBAL_COUNTER", I_INCREMENT_GLOBAL_COUNTER) (* New instructions must be added here, for backward compatibility of the encoding. *) (* Keep the comment above at the end of the list *) ] diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli index 0b02822f021..02753b3aa13 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli @@ -145,6 +145,8 @@ type prim = | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS + | I_GLOBAL_COUNTER + | I_INCREMENT_GLOBAL_COUNTER | T_bool | T_contract | T_int diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index ac2d7e89c29..dbdb81d6c3a 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -235,150 +235,385 @@ let () = group focuses on the evaluation of continuations while the second group is about evaluating the instructions. -*) - -(* - - Evaluation of continuations - =========================== - - As explained in [Script_typed_ir], there are several kinds of - continuations, each having a specific evaluation rules. The - following group of functions starts with a list of evaluation - rules for continuations that generate fresh continuations. This - group ends with the definition of [next], which dispatches - evaluation rules depending on the continuation at stake. - - *) -let rec kmap_exit : - type a b c d e f g h m n o. - (a, b, c, d, e, f, g, h, m, n, o) kmap_exit_type = - fun mk g gas (body, xs, ys, yk) ks accu stack -> - let ys = map_update yk (Some accu) ys in - let ks = mk (KMap_enter_body (body, xs, ys, ks)) in - let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] - -and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = - fun mk g gas body xs ys ks accu stack -> - match xs with - | [] -> - (next [@ocaml.tailcall]) g gas ks ys (accu, stack) - | (xk, xv) :: xs -> - let ks = mk (KMap_exit_body (body, xs, ys, xk, ks)) in - let res = (xk, xv) in - let stack = (accu, stack) in - (step [@ocaml.tailcall]) g gas body ks res stack - [@@inline] - -and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = - fun mk g gas (body, xs, ys, len) ks accu stack -> - let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in - let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack - [@@inline] - -and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = - fun mk g gas (body, xs, ys, len) ks' accu stack -> - match xs with - | [] -> - let ys = {elements = List.rev ys; length = len} in - (next [@ocaml.tailcall]) g gas ks' ys (accu, stack) - | x :: xs -> - let ks = mk (KList_exit_body (body, xs, ys, len, ks')) in - (step [@ocaml.tailcall]) g gas body ks x (accu, stack) - [@@inline] - -and kloop_in_left : - type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = - fun g gas ks0 ki ks' accu stack -> - match accu with - | L v -> - (step [@ocaml.tailcall]) g gas ki ks0 v stack - | R v -> - (next [@ocaml.tailcall]) g gas ks' v stack - [@@inline] - -and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = - fun g gas ks0 ki ks' accu stack -> - let (accu', stack') = stack in - if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' - else (next [@ocaml.tailcall]) g gas ks' accu' stack' - [@@inline] - -and kiter : type a b s r f. (a, b, s, r, f) kiter_type = - fun mk g gas body xs ks accu stack -> - match xs with - | [] -> - (next [@ocaml.tailcall]) g gas ks accu stack - | x :: xs -> - let ks = mk (KIter (body, xs, ks)) in - (step [@ocaml.tailcall]) g gas body ks x (accu, stack) - [@@inline] - -and next : - type a s r f. - outdated_context * step_constants -> - local_gas_counter -> - (a, s, r, f) continuation -> - a -> - s -> - (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = - fun ((ctxt, _) as g) gas ks0 accu stack -> - match consume_control gas ks0 with - | None -> - Lwt.return (Gas.gas_exhausted_error (update_context gas ctxt)) - | Some gas -> ( - match ks0 with - | KLog (ks, logger) -> - (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack - | KNil -> - Lwt.return (Ok (accu, stack, ctxt, gas)) - | KCons (k, ks) -> - (step [@ocaml.tailcall]) g gas k ks accu stack - | KLoop_in (ki, ks') -> - (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks) -> - (next [@ocaml.tailcall]) g gas ks accu stack' - | KLoop_in_left (ki, ks') -> - (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks) -> - (next [@ocaml.tailcall]) g gas ks x (accu, stack) - | KIter (body, xs, ks) -> - (kiter [@ocaml.tailcall]) id g gas body xs ks accu stack - | KList_enter_body (body, xs, ys, len, ks) -> - let extra = (body, xs, ys, len) in - (klist_enter [@ocaml.tailcall]) id g gas extra ks accu stack - | KList_exit_body (body, xs, ys, len, ks) -> - let extra = (body, xs, ys, len) in - (klist_exit [@ocaml.tailcall]) id g gas extra ks accu stack - | KMap_enter_body (body, xs, ys, ks) -> - (kmap_enter [@ocaml.tailcall]) id g gas body xs ys ks accu stack - | KMap_exit_body (body, xs, ys, yk, ks) -> - let extra = (body, xs, ys, yk) in - (kmap_exit [@ocaml.tailcall]) id g gas extra ks accu stack ) - -(* - - Evaluation of instructions - ========================== - - The following functions define evaluation rules for instructions that - generate fresh continuations. As such, they expect a constructor - [log_if_needed] which inserts a [KLog] if the evaluation is logged. - - The [step] function is taking care of the evaluation of the other - instructions. - -*) -and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = - fun log_if_needed g gas body k ks accu stack -> - let xs = accu.elements in - let ys = [] in - let len = accu.length in - let ks = - log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks))) +let cost_of_instr : type b a. (b, a) descr -> b -> Gas.cost = + fun descr stack -> + match (descr.instr, stack) with + | (Drop, _) -> + Interp_costs.drop + | (Dup, _) -> + Interp_costs.dup + | (Swap, _) -> + Interp_costs.swap + | (Const _, _) -> + Interp_costs.push + | (Cons_some, _) -> + Interp_costs.cons_some + | (Cons_none _, _) -> + Interp_costs.cons_none + | (If_none _, _) -> + Interp_costs.if_none + | (Cons_pair, _) -> + Interp_costs.cons_pair + | (Unpair, _) -> + Interp_costs.unpair + | (Car, _) -> + Interp_costs.car + | (Cdr, _) -> + Interp_costs.cdr + | (Cons_left, _) -> + Interp_costs.cons_left + | (Cons_right, _) -> + Interp_costs.cons_right + | (If_left _, _) -> + Interp_costs.if_left + | (Cons_list, _) -> + Interp_costs.cons_list + | (Nil, _) -> + Interp_costs.nil + | (If_cons _, _) -> + Interp_costs.if_cons + | (List_map _, (list, _)) -> + Interp_costs.list_map list + | (List_size, _) -> + Interp_costs.list_size + | (List_iter _, (l, _)) -> + Interp_costs.list_iter l + | (Empty_set _, _) -> + Interp_costs.empty_set + | (Set_iter _, (set, _)) -> + Interp_costs.set_iter set + | (Set_mem, (v, (set, _))) -> + Interp_costs.set_mem v set + | (Set_update, (v, (_, (set, _)))) -> + Interp_costs.set_update v set + | (Set_size, _) -> + Interp_costs.set_size + | (Empty_map _, _) -> + Interp_costs.empty_map + | (Map_map _, (map, _)) -> + Interp_costs.map_map map + | (Map_iter _, (map, _)) -> + Interp_costs.map_iter map + | (Map_mem, (v, (map, _rest))) -> + Interp_costs.map_mem v map + | (Map_get, (v, (map, _rest))) -> + Interp_costs.map_get v map + | (Map_update, (k, (_, (map, _)))) -> + Interp_costs.map_update k map + | (Map_get_and_update, (k, (_, (map, _)))) -> + Interp_costs.map_get_and_update k map + | (Map_size, _) -> + Interp_costs.map_size + | (Empty_big_map _, _) -> + Interp_costs.empty_map + | (Big_map_mem, (_, (map, _))) -> + Interp_costs.big_map_mem map.diff + | (Big_map_get, (_, (map, _))) -> + Interp_costs.big_map_get map.diff + | (Big_map_update, (_, (_, (map, _)))) -> + Interp_costs.big_map_update map.diff + | (Big_map_get_and_update, (_, (_, (map, _)))) -> + Interp_costs.big_map_get_and_update map.diff + | (Add_seconds_to_timestamp, (n, (t, _))) -> + Interp_costs.add_seconds_timestamp n t + | (Add_timestamp_to_seconds, (t, (n, _))) -> + Interp_costs.add_seconds_timestamp n t + | (Sub_timestamp_seconds, (t, (n, _))) -> + Interp_costs.sub_seconds_timestamp n t + | (Diff_timestamps, (t1, (t2, _))) -> + Interp_costs.diff_timestamps t1 t2 + | (Concat_string_pair, (x, (y, _))) -> + Interp_costs.concat_string_pair x y + | (Concat_string, (ss, _)) -> + Interp_costs.concat_string_precheck ss + | (Slice_string, (_offset, (_length, (s, _)))) -> + Interp_costs.slice_string s + | (String_size, _) -> + Interp_costs.string_size + | (Concat_bytes_pair, (x, (y, _))) -> + Interp_costs.concat_bytes_pair x y + | (Concat_bytes, (ss, _)) -> + Interp_costs.concat_string_precheck ss + | (Slice_bytes, (_offset, (_length, (s, _)))) -> + Interp_costs.slice_bytes s + | (Bytes_size, _) -> + Interp_costs.bytes_size + | (Add_tez, _) -> + Interp_costs.add_tez + | (Sub_tez, _) -> + Interp_costs.sub_tez + | (Mul_teznat, (_, (n, _))) -> + Interp_costs.mul_teznat n + | (Mul_nattez, (n, (_, _))) -> + Interp_costs.mul_teznat n + | (Or, _) -> + Interp_costs.bool_or + | (And, _) -> + Interp_costs.bool_and + | (Xor, _) -> + Interp_costs.bool_xor + | (Not, _) -> + Interp_costs.bool_not + | (Is_nat, _) -> + Interp_costs.is_nat + | (Abs_int, (x, _)) -> + Interp_costs.abs_int x + | (Int_nat, _) -> + Interp_costs.int_nat + | (Neg_int, (x, _)) -> + Interp_costs.neg_int x + | (Neg_nat, (x, _)) -> + Interp_costs.neg_nat x + | (Add_intint, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Add_intnat, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Add_natint, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Add_natnat, (x, (y, _))) -> + Interp_costs.add_bigint x y + | (Sub_int, (x, (y, _))) -> + Interp_costs.sub_bigint x y + | (Mul_intint, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Mul_intnat, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Mul_natint, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Mul_natnat, (x, (y, _))) -> + Interp_costs.mul_bigint x y + | (Ediv_teznat, (x, (y, _))) -> + Interp_costs.ediv_teznat x y + | (Ediv_tez, _) -> + Interp_costs.ediv_tez + | (Ediv_intint, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Ediv_intnat, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Ediv_natint, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Ediv_natnat, (x, (y, _))) -> + Interp_costs.ediv_bigint x y + | (Lsl_nat, (x, _)) -> + Interp_costs.lsl_nat x + | (Lsr_nat, (x, _)) -> + Interp_costs.lsr_nat x + | (Or_nat, (x, (y, _))) -> + Interp_costs.or_nat x y + | (And_nat, (x, (y, _))) -> + Interp_costs.and_nat x y + | (And_int_nat, (x, (y, _))) -> + Interp_costs.and_nat x y + | (Xor_nat, (x, (y, _))) -> + Interp_costs.xor_nat x y + | (Not_int, (x, _)) -> + Interp_costs.not_nat x + | (Not_nat, (x, _)) -> + Interp_costs.not_nat x + | (Seq _, _) -> + Interp_costs.seq + | (If _, _) -> + Interp_costs.if_ + | (Loop _, _) -> + Interp_costs.loop + | (Loop_left _, _) -> + Interp_costs.loop_left + | (Dip _, _) -> + Interp_costs.dip + | (Exec, _) -> + Interp_costs.exec + | (Apply _, _) -> + Interp_costs.apply + | (Lambda _, _) -> + Interp_costs.push + | (Failwith _, _) -> + Gas.free + | (Nop, _) -> + Interp_costs.nop + | (Compare ty, (a, (b, _))) -> + Interp_costs.compare ty a b + | (Eq, _) -> + Interp_costs.neq + | (Neq, _) -> + Interp_costs.neq + | (Lt, _) -> + Interp_costs.neq + | (Le, _) -> + Interp_costs.neq + | (Gt, _) -> + Interp_costs.neq + | (Ge, _) -> + Interp_costs.neq + | (Pack _, _) -> + Gas.free + | (Unpack _, _) -> + Gas.free + | (Address, _) -> + Interp_costs.address + | (Contract _, _) -> + Interp_costs.contract + | (Transfer_tokens, _) -> + Interp_costs.transfer_tokens + | (Increment_global_counter, _) -> + Interp_costs.increment_global_counter + | (Implicit_account, _) -> + Interp_costs.implicit_account + | (Set_delegate, _) -> + Interp_costs.set_delegate + | (Balance, _) -> + Interp_costs.balance + | (Level, _) -> + Interp_costs.level + | (Now, _) -> + Interp_costs.now + | (Check_signature, (key, (_, (message, _)))) -> + Interp_costs.check_signature key message + | (Hash_key, (pk, _)) -> + Interp_costs.hash_key pk + | (Blake2b, (bytes, _)) -> + Interp_costs.blake2b bytes + | (Sha256, (bytes, _)) -> + Interp_costs.sha256 bytes + | (Sha512, (bytes, _)) -> + Interp_costs.sha512 bytes + | (Source, _) -> + Interp_costs.source + | (Sender, _) -> + Interp_costs.source + | (Self _, _) -> + Interp_costs.self + | (Self_address, _) -> + Interp_costs.self + | (Amount, _) -> + Interp_costs.amount + | (Dig (n, _), _) -> + Interp_costs.dign n + | (Dug (n, _), _) -> + Interp_costs.dugn n + | (Dipn (n, _, _), _) -> + Interp_costs.dipn n + | (Dropn (n, _), _) -> + Interp_costs.dropn n + | (ChainId, _) -> + Interp_costs.chain_id + | (Create_contract _, _) -> + Interp_costs.create_contract + | (Never, (_, _)) -> + . + | (Voting_power, _) -> + Interp_costs.voting_power + | (Total_voting_power, _) -> + Interp_costs.total_voting_power + | (Keccak, (bytes, _)) -> + Interp_costs.keccak bytes + | (Sha3, (bytes, _)) -> + Interp_costs.sha3 bytes + | (Add_bls12_381_g1, _) -> + Interp_costs.add_bls12_381_g1 + | (Add_bls12_381_g2, _) -> + Interp_costs.add_bls12_381_g2 + | (Add_bls12_381_fr, _) -> + Interp_costs.add_bls12_381_fr + | (Mul_bls12_381_g1, _) -> + Interp_costs.mul_bls12_381_g1 + | (Mul_bls12_381_g2, _) -> + Interp_costs.mul_bls12_381_g2 + | (Mul_bls12_381_fr, _) -> + Interp_costs.mul_bls12_381_fr + | (Mul_bls12_381_fr_z, _) -> + Interp_costs.mul_bls12_381_fr_z + | (Mul_bls12_381_z_fr, _) -> + Interp_costs.mul_bls12_381_fr_z + | (Int_bls12_381_fr, _) -> + Interp_costs.int_bls12_381_fr + | (Neg_bls12_381_g1, _) -> + Interp_costs.neg_bls12_381_g1 + | (Neg_bls12_381_g2, _) -> + Interp_costs.neg_bls12_381_g2 + | (Neg_bls12_381_fr, _) -> + Interp_costs.neg_bls12_381_fr + | (Pairing_check_bls12_381, (pairs, _)) -> + Interp_costs.pairing_check_bls12_381 pairs + | (Comb (n, _), _) -> + Interp_costs.comb n + | (Uncomb (n, _), _) -> + Interp_costs.uncomb n + | (Comb_get (n, _), _) -> + Interp_costs.comb_get n + | (Comb_set (n, _), _) -> + Interp_costs.comb_set n + | (Dup_n (n, _), _) -> + Interp_costs.dupn n + | (Sapling_empty_state _, _) -> + Interp_costs.sapling_empty_state + | (Sapling_verify_update, (tx, _)) -> + let inputs = List.length tx.inputs in + let outputs = List.length tx.outputs in + Interp_costs.sapling_verify_update ~inputs ~outputs + | (Ticket, _) -> + Interp_costs.ticket + | (Read_ticket, _) -> + Interp_costs.read_ticket + | (Split_ticket, (ticket, ((amount_a, amount_b), _))) -> + Interp_costs.split_ticket ticket.amount amount_a amount_b + | (Join_tickets ty, ((ticket_a, ticket_b), _)) -> + Interp_costs.join_tickets ty ticket_a ticket_b + +let unpack ctxt ~ty ~bytes = + Gas.check_enough ctxt (Script.serialized_cost bytes) + >>?= fun () -> + if + Compare.Int.(Bytes.length bytes >= 1) + && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05) + then + let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in + match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with + | None -> + Lwt.return + ( Gas.consume ctxt (Interp_costs.unpack_failed bytes) + >|? fun ctxt -> (None, ctxt) ) + | Some expr -> ( + Gas.consume ctxt (Script.deserialized_cost expr) + >>?= fun ctxt -> + parse_data + ctxt + ~legacy:false + ~allow_forged:false + ty + (Micheline.root expr) + >|= function + | Ok (value, ctxt) -> + ok (Some value, ctxt) + | Error _ignored -> + Gas.consume ctxt (Interp_costs.unpack_failed bytes) + >|? fun ctxt -> (None, ctxt) ) + else return (None, ctxt) + +let rec step_bounded : + type b a. + logger -> + stack_depth:int -> + context -> + step_constants -> + (b, a) descr -> + b -> + (a * context) tzresult Lwt.t = + fun logger ~stack_depth ctxt step_constants ({instr; loc; _} as descr) stack -> + let gas = cost_of_instr descr stack in + Gas.consume ctxt gas + >>?= fun ctxt -> + let module Log = (val logger) in + Log.log_entry ctxt descr stack ; + let logged_return : a * context -> (a * context) tzresult Lwt.t = + fun (ret, ctxt) -> + Log.log_exit ctxt descr ret ; + return (ret, ctxt) + in + let non_terminal_recursion ~ctxt ?(stack_depth = stack_depth + 1) descr stack + = + if Compare.Int.(stack_depth >= 10_000) then + fail Michelson_too_many_recursive_calls + else step_bounded logger ~stack_depth ctxt step_constants descr stack in let (accu, stack) = stack in (next [@ocaml.tailcall]) g gas ks accu stack @@ -858,258 +1093,454 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = match Script_int.to_int64 r with | None -> assert false (* Cannot overflow *) - | Some r -> ( - match Tez.of_mutez r with - | None -> - assert false (* Cannot overflow *) - | Some r -> - Some (q, r) ) ) - in - (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_intint (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.ediv x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_intnat (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.ediv x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_natint (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.ediv x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_natnat (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.ediv_n x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (kinfo, k) -> - ilsl_nat None g gas kinfo k ks accu stack - | ILsr_nat (kinfo, k) -> - ilsr_nat None g gas kinfo k ks accu stack - | IOr_nat (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.logor x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_nat (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.logand x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_int_nat (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.logand x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | IXor_nat (_, k) -> - let x = accu and (y, stack) = stack in - let res = Script_int.logxor x y in - (step [@ocaml.tailcall]) g gas k ks res stack - | INot_int (_, k) -> - let x = accu in - let res = Script_int.lognot x in - (step [@ocaml.tailcall]) g gas k ks res stack - | INot_nat (_, k) -> - let x = accu in - let res = Script_int.lognot x in - (step [@ocaml.tailcall]) g gas k ks res stack - (* control *) - | IIf {branch_if_true; branch_if_false} -> - let (res, stack) = stack in - if accu then (step [@ocaml.tailcall]) g gas branch_if_true ks res stack - else (step [@ocaml.tailcall]) g gas branch_if_false ks res stack - | ILoop (_, body, k) -> - let ks = KLoop_in (body, KCons (k, ks)) in - (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> - let ks = KLoop_in_left (bl, KCons (br, ks)) in - (next [@ocaml.tailcall]) g gas ks accu stack - | IDip (_, b, k) -> - let ign = accu in - let ks = KUndip (ign, KCons (k, ks)) in - let (accu, stack) = stack in - (step [@ocaml.tailcall]) g gas b ks accu stack - | IExec (_, k) -> - iexec None g gas k ks accu stack - | IApply (_, capture_ty, k) -> - let capture = accu in - let (lam, stack) = stack in - apply ctxt gas capture_ty capture lam - >>=? fun (lam', ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack - | ILambda (_, lam, k) -> - (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) - | IFailwith (_, kloc, tv, _) -> - ifailwith None g gas kloc tv accu - (* comparison *) - | ICompare (_, ty, k) -> - let a = accu in - let (b, stack) = stack in - let r = - Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b - in - (step [@ocaml.tailcall]) g gas k ks r stack - (* comparators *) - | IEq (_, k) -> - let a = accu in - let a = Script_int.compare a Script_int.zero in - let a = Compare.Int.(a = 0) in - (step [@ocaml.tailcall]) g gas k ks a stack - | INeq (_, k) -> - let a = accu in - let a = Script_int.compare a Script_int.zero in - let a = Compare.Int.(a <> 0) in - (step [@ocaml.tailcall]) g gas k ks a stack - | ILt (_, k) -> - let a = accu in - let a = Script_int.compare a Script_int.zero in - let a = Compare.Int.(a < 0) in - (step [@ocaml.tailcall]) g gas k ks a stack - | ILe (_, k) -> - let a = accu in - let a = Script_int.compare a Script_int.zero in - let a = Compare.Int.(a <= 0) in - (step [@ocaml.tailcall]) g gas k ks a stack - | IGt (_, k) -> - let a = accu in - let a = Script_int.compare a Script_int.zero in - let a = Compare.Int.(a > 0) in - (step [@ocaml.tailcall]) g gas k ks a stack - | IGe (_, k) -> - let a = accu in - let a = Script_int.compare a Script_int.zero in - let a = Compare.Int.(a >= 0) in - (step [@ocaml.tailcall]) g gas k ks a stack - (* packing *) - | IPack (_, ty, k) -> - let value = accu in - ( use_gas_counter_in_ctxt ctxt gas - @@ fun ctxt -> Script_ir_translator.pack_data ctxt ty value ) - >>=? fun (bytes, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack - | IUnpack (_, ty, k) -> - let bytes = accu in - (use_gas_counter_in_ctxt ctxt gas @@ fun ctxt -> unpack ctxt ~ty ~bytes) - >>=? fun (opt, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack - | IAddress (_, k) -> - let (_, address) = accu in - (step [@ocaml.tailcall]) g gas k ks address stack - | IContract (kinfo, t, entrypoint, k) -> ( - let contract = accu in - match (contract, entrypoint) with - | ((contract, "default"), entrypoint) - | ((contract, entrypoint), "default") -> - let ctxt = update_context gas ctxt in - Script_ir_translator.parse_contract_for_script - ctxt - kinfo.iloc - t - contract - ~entrypoint - >>=? fun (ctxt, maybe_contract) -> - let gas = update_local_gas_counter ctxt in - let ctxt = outdated ctxt in - let accu = maybe_contract in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | _ -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack ) - | ITransfer_tokens (_, k) -> - let p = accu in - let (amount, ((tp, (destination, entrypoint)), stack)) = stack in - transfer (ctxt, sc) gas amount tp p destination entrypoint - >>=? fun (accu, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | IImplicit_account (_, k) -> - let key = accu in - let contract = Contract.implicit_contract key in - let res = (Unit_t None, (contract, "default")) in - (step [@ocaml.tailcall]) g gas k ks res stack - | ICreate_contract - {storage_type; arg_type; lambda = Lam (_, code); root_name; k} -> - (* Removed the instruction's arguments manager, spendable and delegatable *) - let delegate = accu in - let (credit, (init, stack)) = stack in - create_contract - g - gas - storage_type - arg_type - code - root_name - delegate - credit - init - >>=? fun (res, contract, ctxt, gas) -> - let stack = ((contract, "default"), stack) in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | ISet_delegate (_, k) -> - let delegate = accu in - let operation = Delegation delegate in - let ctxt = update_context gas ctxt in - fresh_internal_nonce ctxt - >>?= fun (ctxt, nonce) -> - let res = - (Internal_operation {source = sc.self; operation; nonce}, None) - in - let gas = update_local_gas_counter ctxt in - let ctxt = outdated ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBalance (_, k) -> - let ctxt = update_context gas ctxt in - Contract.get_balance_carbonated ctxt sc.self - >>=? fun (ctxt, balance) -> - let gas = update_local_gas_counter ctxt in - let ctxt = outdated ctxt in - let g = (ctxt, sc) in - (step [@ocaml.tailcall]) g gas k ks balance (accu, stack) - | ILevel (_, k) -> - let level = - (Level.current (context_from_outdated_context ctxt)).level - |> Raw_level.to_int32 |> Script_int.of_int32 |> Script_int.abs - in - (step [@ocaml.tailcall]) g gas k ks level (accu, stack) - | INow (_, k) -> - let now = Script_timestamp.now (context_from_outdated_context ctxt) in - (step [@ocaml.tailcall]) g gas k ks now (accu, stack) - | ICheck_signature (_, k) -> - let key = accu and (signature, (message, stack)) = stack in - let res = Signature.check key signature message in - (step [@ocaml.tailcall]) g gas k ks res stack - | IHash_key (_, k) -> - let key = accu in - let res = Signature.Public_key.hash key in - (step [@ocaml.tailcall]) g gas k ks res stack - | IBlake2b (_, k) -> - let bytes = accu in - let hash = Raw_hashes.blake2b bytes in - (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha256 (_, k) -> - let bytes = accu in - let hash = Raw_hashes.sha256 bytes in - (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha512 (_, k) -> - let bytes = accu in - let hash = Raw_hashes.sha512 bytes in - (step [@ocaml.tailcall]) g gas k ks hash stack - | ISource (_, k) -> - let res = (sc.payer, "default") in - (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISender (_, k) -> - let res = (sc.source, "default") in - (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf (_, ty, entrypoint, k) -> - let res = (ty, (sc.self, entrypoint)) in - (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf_address (_, k) -> - let res = (sc.self, "default") in - (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | IAmount (_, k) -> - let accu = sc.amount and stack = (accu, stack) in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IDig (_, _n, n', k) -> - let ((accu, stack), x) = - interp_stack_prefix_preserving_operation - (fun v stack -> (stack, v)) - n' - accu + | Some r -> + Some (q, r) ) ) + in + logged_return ((result, rest), ctxt) + | (Ediv_intint, (x, (y, rest))) -> + logged_return ((Script_int.ediv x y, rest), ctxt) + | (Ediv_intnat, (x, (y, rest))) -> + logged_return ((Script_int.ediv x y, rest), ctxt) + | (Ediv_natint, (x, (y, rest))) -> + logged_return ((Script_int.ediv x y, rest), ctxt) + | (Ediv_natnat, (x, (y, rest))) -> + logged_return ((Script_int.ediv_n x y, rest), ctxt) + | (Lsl_nat, (x, (y, rest))) -> ( + match Script_int.shift_left_n x y with + | None -> + Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) + | Some x -> + logged_return ((x, rest), ctxt) ) + | (Lsr_nat, (x, (y, rest))) -> ( + match Script_int.shift_right_n x y with + | None -> + Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) + | Some r -> + logged_return ((r, rest), ctxt) ) + | (Or_nat, (x, (y, rest))) -> + logged_return ((Script_int.logor x y, rest), ctxt) + | (And_nat, (x, (y, rest))) -> + logged_return ((Script_int.logand x y, rest), ctxt) + | (And_int_nat, (x, (y, rest))) -> + logged_return ((Script_int.logand x y, rest), ctxt) + | (Xor_nat, (x, (y, rest))) -> + logged_return ((Script_int.logxor x y, rest), ctxt) + | (Not_int, (x, rest)) -> + logged_return ((Script_int.lognot x, rest), ctxt) + | (Not_nat, (x, rest)) -> + logged_return ((Script_int.lognot x, rest), ctxt) + (* control *) + | (Seq (hd, tl), stack) -> + non_terminal_recursion ~ctxt hd stack + >>=? fun (trans, ctxt) -> + step_bounded logger ~stack_depth ctxt step_constants tl trans + | (If (bt, _), (true, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bt rest + | (If (_, bf), (false, rest)) -> + step_bounded logger ~stack_depth ctxt step_constants bf rest + | (Loop body, (true, rest)) -> + non_terminal_recursion ~ctxt body rest + >>=? fun (trans, ctxt) -> + step_bounded logger ~stack_depth ctxt step_constants descr trans + | (Loop _, (false, rest)) -> + logged_return (rest, ctxt) + | (Loop_left body, (L v, rest)) -> + non_terminal_recursion ~ctxt body (v, rest) + >>=? fun (trans, ctxt) -> + step_bounded logger ~stack_depth ctxt step_constants descr trans + | (Loop_left _, (R v, rest)) -> + logged_return ((v, rest), ctxt) + | (Dip b, (ign, rest)) -> + non_terminal_recursion ~ctxt b rest + >>=? fun (res, ctxt) -> logged_return ((ign, res), ctxt) + | (Exec, (arg, (Lam (code, _), rest))) -> + Log.log_interp ctxt code (arg, ()) ; + non_terminal_recursion ~ctxt code (arg, ()) + >>=? fun ((res, ()), ctxt) -> logged_return ((res, rest), ctxt) + | (Apply capture_ty, (capture, (lam, rest))) -> ( + let (Lam (descr, expr)) = lam in + let (Item_t (full_arg_ty, _, _)) = descr.bef in + unparse_data ctxt Optimized capture_ty capture + >>=? fun (const_expr, ctxt) -> + unparse_ty ctxt capture_ty + >>?= fun (ty_expr, ctxt) -> + match full_arg_ty with + | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _) -> + let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in + let const_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = Item_t (capture_ty, arg_stack_ty, None); + instr = Const capture; + } + : (_, _) descr ) + in + let pair_descr = + ( { + loc = descr.loc; + bef = Item_t (capture_ty, arg_stack_ty, None); + aft = Item_t (full_arg_ty, Empty_t, None); + instr = Cons_pair; + } + : (_, _) descr ) + in + let seq_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = Item_t (full_arg_ty, Empty_t, None); + instr = Seq (const_descr, pair_descr); + } + : (_, _) descr ) + in + let full_descr = + ( { + loc = descr.loc; + bef = arg_stack_ty; + aft = descr.aft; + instr = Seq (seq_descr, descr); + } + : (_, _) descr ) + in + let full_expr = + Micheline.Seq + ( 0, + [ Prim (0, I_PUSH, [ty_expr; const_expr], []); + Prim (0, I_PAIR, [], []); + expr ] ) + in + let lam' = Lam (full_descr, full_expr) in + logged_return ((lam', rest), ctxt) + | _ -> + assert false ) + | (Lambda lam, rest) -> + logged_return ((lam, rest), ctxt) + | (Failwith tv, (v, _)) -> + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + Log.get_log () >>=? fun log -> fail (Reject (loc, v, log)) + | (Nop, stack) -> + logged_return (stack, ctxt) + (* comparison *) + | (Compare ty, (a, (b, rest))) -> + logged_return + ( ( Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b, + rest ), + ctxt ) + (* comparators *) + | (Eq, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres = 0) in + logged_return ((cmpres, rest), ctxt) + | (Neq, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <> 0) in + logged_return ((cmpres, rest), ctxt) + | (Lt, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres < 0) in + logged_return ((cmpres, rest), ctxt) + | (Le, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres <= 0) in + logged_return ((cmpres, rest), ctxt) + | (Gt, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres > 0) in + logged_return ((cmpres, rest), ctxt) + | (Ge, (cmpres, rest)) -> + let cmpres = Script_int.compare cmpres Script_int.zero in + let cmpres = Compare.Int.(cmpres >= 0) in + logged_return ((cmpres, rest), ctxt) + (* packing *) + | (Pack t, (value, rest)) -> + Script_ir_translator.pack_data ctxt t value + >>=? fun (bytes, ctxt) -> logged_return ((bytes, rest), ctxt) + | (Unpack ty, (bytes, rest)) -> + unpack ctxt ~ty ~bytes + >>=? fun (opt, ctxt) -> logged_return ((opt, rest), ctxt) + (* protocol *) + | (Address, ((_, address), rest)) -> + logged_return ((address, rest), ctxt) + | (Contract (t, entrypoint), (contract, rest)) -> ( + match (contract, entrypoint) with + | ((contract, "default"), entrypoint) | ((contract, entrypoint), "default") + -> + Script_ir_translator.parse_contract_for_script + ctxt + loc + t + contract + ~entrypoint + >>=? fun (ctxt, maybe_contract) -> + logged_return ((maybe_contract, rest), ctxt) + | _ -> + logged_return ((None, rest), ctxt) ) + | (Transfer_tokens, (p, (amount, ((tp, (destination, entrypoint)), rest)))) + -> + collect_lazy_storage ctxt tp p + >>?= fun (to_duplicate, ctxt) -> + let to_update = no_lazy_storage_id in + extract_lazy_storage_diff + ctxt + Optimized + tp + p + ~to_duplicate + ~to_update + ~temporary:true + >>=? fun (p, lazy_storage_diff, ctxt) -> + unparse_data ctxt Optimized tp p + >>=? fun (p, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost p) + >>?= fun ctxt -> + let operation = + Transaction + { + amount; + destination; + entrypoint; + parameters = Script.lazy_expr (Micheline.strip_locations p); + } + in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + let packed_op = + Internal_operation {source = step_constants.self; operation; nonce} + in + logged_return (((packed_op, lazy_storage_diff), rest), ctxt) + | (Increment_global_counter, rest) -> + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + let operation = + Internal_operation + { + source = step_constants.self; + operation = Global_counter_increment; + nonce; + } + in + logged_return (((operation, None), rest), ctxt) + | (Implicit_account, (key, rest)) -> + let contract = Contract.implicit_contract key in + logged_return (((Unit_t None, (contract, "default")), rest), ctxt) + | ( Create_contract (storage_type, param_type, Lam (_, code), root_name), + (* Removed the instruction's arguments manager, spendable and delegatable *) + (delegate, (credit, (init, rest))) ) -> + unparse_ty ctxt param_type + >>?= fun (unparsed_param_type, ctxt) -> + let unparsed_param_type = + Script_ir_translator.add_field_annot root_name None unparsed_param_type + in + unparse_ty ctxt storage_type + >>?= fun (unparsed_storage_type, ctxt) -> + let code = + Micheline.strip_locations + (Seq + ( 0, + [ Prim (0, K_parameter, [unparsed_param_type], []); + Prim (0, K_storage, [unparsed_storage_type], []); + Prim (0, K_code, [code], []) ] )) + in + collect_lazy_storage ctxt storage_type init + >>?= fun (to_duplicate, ctxt) -> + let to_update = no_lazy_storage_id in + extract_lazy_storage_diff + ctxt + Optimized + storage_type + init + ~to_duplicate + ~to_update + ~temporary:true + >>=? fun (init, lazy_storage_diff, ctxt) -> + unparse_data ctxt Optimized storage_type init + >>=? fun (storage, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost storage) + >>?= fun ctxt -> + let storage = Micheline.strip_locations storage in + Contract.fresh_contract_from_current_nonce ctxt + >>?= fun (ctxt, contract) -> + let operation = + Origination + { + credit; + delegate; + preorigination = Some contract; + script = + { + code = Script.lazy_expr code; + storage = Script.lazy_expr storage; + }; + } + in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + logged_return + ( ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + lazy_storage_diff ), + ((contract, "default"), rest) ), + ctxt ) + | (Set_delegate, (delegate, rest)) -> + let operation = Delegation delegate in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + logged_return + ( ( ( Internal_operation + {source = step_constants.self; operation; nonce}, + None ), + rest ), + ctxt ) + | (Balance, rest) -> + Contract.get_balance_carbonated ctxt step_constants.self + >>=? fun (ctxt, balance) -> logged_return ((balance, rest), ctxt) + | (Level, rest) -> + let level = + (Level.current ctxt).level |> Raw_level.to_int32 |> Script_int.of_int32 + |> Script_int.abs + in + logged_return ((level, rest), ctxt) + | (Now, rest) -> + let now = Script_timestamp.now ctxt in + logged_return ((now, rest), ctxt) + | (Check_signature, (key, (signature, (message, rest)))) -> + let res = Signature.check key signature message in + logged_return ((res, rest), ctxt) + | (Hash_key, (key, rest)) -> + logged_return ((Signature.Public_key.hash key, rest), ctxt) + | (Blake2b, (bytes, rest)) -> + let hash = Raw_hashes.blake2b bytes in + logged_return ((hash, rest), ctxt) + | (Sha256, (bytes, rest)) -> + let hash = Raw_hashes.sha256 bytes in + logged_return ((hash, rest), ctxt) + | (Sha512, (bytes, rest)) -> + let hash = Raw_hashes.sha512 bytes in + logged_return ((hash, rest), ctxt) + | (Source, rest) -> + logged_return (((step_constants.payer, "default"), rest), ctxt) + | (Sender, rest) -> + logged_return (((step_constants.source, "default"), rest), ctxt) + | (Self (t, entrypoint), rest) -> + logged_return (((t, (step_constants.self, entrypoint)), rest), ctxt) + | (Self_address, rest) -> + logged_return (((step_constants.self, "default"), rest), ctxt) + | (Amount, rest) -> + logged_return ((step_constants.amount, rest), ctxt) + | (Dig (_n, n'), stack) -> + interp_stack_prefix_preserving_operation + (fun (v, rest) -> return (rest, v)) + n' + stack + >>=? fun (aft, x) -> logged_return ((x, aft), ctxt) + | (Dug (_n, n'), (v, rest)) -> + interp_stack_prefix_preserving_operation + (fun stk -> return ((v, stk), ())) + n' + rest + >>=? fun (aft, ()) -> logged_return (aft, ctxt) + | (Dipn (n, n', b), stack) -> + interp_stack_prefix_preserving_operation + (fun stk -> + non_terminal_recursion + ~ctxt + b + stk + (* This is a cheap upper bound of the number recursive calls to + `interp_stack_prefix_preserving_operation`, which does + ((n / 16) + log2 (n % 16)) iterations *) + ~stack_depth:(stack_depth + 4 + (n / 16))) + n' + stack + >>=? fun (aft, ctxt') -> logged_return (aft, ctxt') + | (Dropn (_n, n'), stack) -> + interp_stack_prefix_preserving_operation + (fun stk -> return (stk, stk)) + n' + stack + >>=? fun (_, rest) -> logged_return (rest, ctxt) + | (Sapling_empty_state {memo_size}, stack) -> + logged_return ((Sapling.empty_state ~memo_size (), stack), ctxt) + | (Sapling_verify_update, (transaction, (state, rest))) -> ( + let address = Contract.to_b58check step_constants.self in + let chain_id = Chain_id.to_b58check step_constants.chain_id in + let anti_replay = address ^ chain_id in + Sapling.verify_update ctxt state transaction anti_replay + >>=? fun (ctxt, balance_state_opt) -> + match balance_state_opt with + | Some (balance, state) -> + logged_return + ((Some (Script_int.of_int64 balance, state), rest), ctxt) + | None -> + logged_return ((None, rest), ctxt) ) + | (ChainId, rest) -> + logged_return ((step_constants.chain_id, rest), ctxt) + | (Never, (_, _)) -> + . + | (Voting_power, (key_hash, rest)) -> + Vote.get_voting_power ctxt key_hash + >>=? fun (ctxt, rolls) -> + logged_return ((Script_int.(abs (of_int32 rolls)), rest), ctxt) + | (Total_voting_power, rest) -> + Vote.get_total_voting_power ctxt + >>=? fun (ctxt, rolls) -> + logged_return ((Script_int.(abs (of_int32 rolls)), rest), ctxt) + | (Keccak, (bytes, rest)) -> + let hash = Raw_hashes.keccak256 bytes in + logged_return ((hash, rest), ctxt) + | (Sha3, (bytes, rest)) -> + let hash = Raw_hashes.sha3_256 bytes in + logged_return ((hash, rest), ctxt) + | (Add_bls12_381_g1, (x, (y, rest))) -> + logged_return ((Bls12_381.G1.add x y, rest), ctxt) + | (Add_bls12_381_g2, (x, (y, rest))) -> + logged_return ((Bls12_381.G2.add x y, rest), ctxt) + | (Add_bls12_381_fr, (x, (y, rest))) -> + logged_return ((Bls12_381.Fr.add x y, rest), ctxt) + | (Mul_bls12_381_g1, (x, (y, rest))) -> + logged_return ((Bls12_381.G1.mul x y, rest), ctxt) + | (Mul_bls12_381_g2, (x, (y, rest))) -> + logged_return ((Bls12_381.G2.mul x y, rest), ctxt) + | (Mul_bls12_381_fr, (x, (y, rest))) -> + logged_return ((Bls12_381.Fr.mul x y, rest), ctxt) + | (Mul_bls12_381_fr_z, (x, (y, rest))) -> + let x = Bls12_381.Fr.of_z (Script_int.to_zint x) in + let res = (Bls12_381.Fr.mul x y, rest) in + logged_return (res, ctxt) + | (Mul_bls12_381_z_fr, (y, (x, rest))) -> + let x = Bls12_381.Fr.of_z (Script_int.to_zint x) in + let res = (Bls12_381.Fr.mul x y, rest) in + logged_return (res, ctxt) + | (Int_bls12_381_fr, (x, rest)) -> + logged_return ((Script_int.of_zint (Bls12_381.Fr.to_z x), rest), ctxt) + | (Neg_bls12_381_g1, (x, rest)) -> + logged_return ((Bls12_381.G1.negate x, rest), ctxt) + | (Neg_bls12_381_g2, (x, rest)) -> + logged_return ((Bls12_381.G2.negate x, rest), ctxt) + | (Neg_bls12_381_fr, (x, rest)) -> + logged_return ((Bls12_381.Fr.negate x, rest), ctxt) + | (Pairing_check_bls12_381, (pairs, rest)) -> + let check = + match pairs.elements with + | [] -> + true + | pairs -> + Bls12_381.( + miller_loop pairs |> final_exponentiation_opt + |> Option.map Gt.(eq one)) + |> Option.value ~default:false + in + logged_return ((check, rest), ctxt) + | (Comb (_, witness), stack) -> + let rec aux : + type before after. + (before, after) comb_gadt_witness -> before -> after = + fun witness stack -> + match (witness, stack) with + | (Comb_one, stack) -> stack in let accu = x and stack = (accu, stack) in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a5a261be939..cfc3dea9493 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5471,9 +5471,15 @@ and parse_instr : Item_t (Option_t (Key_hash_t _, _), rest, _) ) -> parse_var_annot loc annot >>?= fun annot -> - let instr = {apply = (fun kinfo k -> ISet_delegate (kinfo, k))} in - let stack = Item_t (Operation_t None, rest, annot) in - typed ctxt 0 loc instr stack + typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) + | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), rest) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + IIncrement_global_counter + (Item_t (Operation_t None, rest, annot)) | (Prim (_, I_CREATE_ACCOUNT, _, _), _) -> fail (Deprecated_instruction I_CREATE_ACCOUNT) | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _)) @@ -5888,7 +5894,15 @@ and parse_instr : let stack = Item_t (Option_t (ty, None), rest, annot) in typed ctxt 0 loc instr stack | _ -> - (* TODO: fix injectivity of types *) assert false ) + | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), rest) -> + parse_var_annot loc annot + >>?= fun annot -> + typed + ctxt + loc + Increment_global_counter + (Item_t (Operation_t None, rest, annot)) + (* TODO: fix injectivity of types *) assert false ) (* Primitive parsing errors *) | ( Prim ( loc, @@ -5958,7 +5972,8 @@ and parse_instr : | I_TICKET | I_READ_TICKET | I_SPLIT_TICKET - | I_JOIN_TICKETS ) as name ), + | I_JOIN_TICKETS + | I_INCREMENT_GLOBAL_COUNTER) as name ), (_ :: _ as l), _ ), _ ) -> @@ -6101,7 +6116,8 @@ and parse_instr : | I_KECCAK | I_SHA3 | I_READ_TICKET - | I_JOIN_TICKETS ) as name ), + | I_JOIN_TICKETS + | I_INCREMENT_GLOBAL_COUNTER) as name ), _, _ ), stack ) -> @@ -6227,7 +6243,8 @@ and parse_instr : I_TICKET; I_READ_TICKET; I_SPLIT_TICKET; - I_JOIN_TICKETS ] + I_JOIN_TICKETS; + I_INCREMENT_GLOBAL_COUNTER ] and parse_contract : type arg. diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index f71dcd6bd32..16c43e76bc3 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -934,7 +934,8 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | IHalt : ('a, 's) kinfo -> ('a, 's, 'a, 's) kinstr | ILog : ('a, 's) kinfo * logging_event * logger * ('a, 's, 'r, 'f) kinstr - -> ('a, 's, 'r, 'f) kinstr + -> ('a, 's, 'r, 'f) kinstr + | IIncrement_global_counter : ('rest, operation * 'rest) instr and logging_event = | LogEntry : logging_event @@ -1905,4 +1906,4 @@ let kinstr_rewritek : | IHalt kinfo -> IHalt kinfo | ILog (kinfo, event, logger, k) -> - ILog (kinfo, event, logger, k) + ILog (kinfo, event, logger, k) \ No newline at end of file -- GitLab From df2dadb701fd9dad65ee005dfdc887e8ce1e0277 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Fri, 21 May 2021 16:25:08 +0100 Subject: [PATCH 15/33] Remove instruction for reading global counter --- src/proto_alpha/lib_protocol/alpha_context.mli | 1 - src/proto_alpha/lib_protocol/michelson_v1_primitives.ml | 7 ------- src/proto_alpha/lib_protocol/michelson_v1_primitives.mli | 1 - 3 files changed, 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index fdcc330e625..cee739f5936 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -400,7 +400,6 @@ module Script : sig | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS - | I_GLOBAL_COUNTER | I_INCREMENT_GLOBAL_COUNTER | T_bool | T_contract diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 0994c1c3ffa..0a3791dc22d 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -146,7 +146,6 @@ type prim = | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS - | I_GLOBAL_COUNTER | I_INCREMENT_GLOBAL_COUNTER | T_bool | T_contract @@ -299,7 +298,6 @@ let namespace = function | I_UPDATE | I_VOTING_POWER | I_XOR - | I_GLOBAL_COUNTER | I_INCREMENT_GLOBAL_COUNTER -> Instr_namespace | T_address @@ -571,8 +569,6 @@ let string_of_prim = function "SPLIT_TICKET" | I_JOIN_TICKETS -> "JOIN_TICKETS" - | I_GLOBAL_COUNTER -> - "GLOBAL_COUNTER" | I_INCREMENT_GLOBAL_COUNTER -> "INCREMENT_GLOBAL_COUNTER" | T_bool -> @@ -859,8 +855,6 @@ let prim_of_string = function ok I_SPLIT_TICKET | "JOIN_TICKETS" -> ok I_JOIN_TICKETS - | "GLOBAL_COUNTER" -> - ok I_GLOBAL_COUNTER | "INCREMENT_GLOBAL_COUNTER" -> ok I_INCREMENT_GLOBAL_COUNTER | "bool" -> @@ -1126,7 +1120,6 @@ let prim_encoding = ("SPLIT_TICKET", I_SPLIT_TICKET); ("JOIN_TICKETS", I_JOIN_TICKETS); ("GET_AND_UPDATE", I_GET_AND_UPDATE); - ("GLOBAL_COUNTER", I_GLOBAL_COUNTER); ("INCREMENT_GLOBAL_COUNTER", I_INCREMENT_GLOBAL_COUNTER) (* New instructions must be added here, for backward compatibility of the encoding. *) (* Keep the comment above at the end of the list *) diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli index 02753b3aa13..861855dd0cc 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli @@ -145,7 +145,6 @@ type prim = | I_READ_TICKET | I_SPLIT_TICKET | I_JOIN_TICKETS - | I_GLOBAL_COUNTER | I_INCREMENT_GLOBAL_COUNTER | T_bool | T_contract -- GitLab From ef449b2022d8e0406ce209ea2ce8aada3ebd01d2 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Mon, 24 May 2021 14:45:19 +0100 Subject: [PATCH 16/33] Adding a couple of tests --- .../lib_protocol/test/helpers/context.ml | 3 +++ .../lib_protocol/test/helpers/context.mli | 2 ++ src/proto_alpha/lib_protocol/test/helpers/op.ml | 14 ++++++++++++++ src/proto_alpha/lib_protocol/test/helpers/op.mli | 9 +++++++++ src/proto_alpha/lib_protocol/test/main.ml | 3 ++- 5 files changed, 30 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.ml b/src/proto_alpha/lib_protocol/test/helpers/context.ml index fef9d7916f3..540504829c4 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/context.ml @@ -181,6 +181,9 @@ let get_liquidity_baking_subsidy ctxt = let get_liquidity_baking_cpmm_address ctxt = Alpha_services.Liquidity_baking.get_cpmm_address rpc_ctxt ctxt +let get_global_counter ctxt = + Alpha_services.Global_variables.get_global_counter rpc_ctxt ctxt () + (* Voting *) module Vote = struct diff --git a/src/proto_alpha/lib_protocol/test/helpers/context.mli b/src/proto_alpha/lib_protocol/test/helpers/context.mli index daa7b51b422..0dd69d6ad79 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/context.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/context.mli @@ -65,6 +65,8 @@ val get_endorsing_reward : val get_liquidity_baking_subsidy : t -> Tez.t tzresult Lwt.t +val get_global_counter : t -> int32 tzresult Lwt.t + val get_liquidity_baking_cpmm_address : t -> Contract.t tzresult Lwt.t module Vote : sig diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.ml b/src/proto_alpha/lib_protocol/test/helpers/op.ml index 2b982650af5..ddec217207e 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/op.ml @@ -330,6 +330,20 @@ let transaction ?counter ?fee ?gas_limit ?storage_limit Context.Contract.manager ctxt src >|=? fun account -> sign account.sk ctxt sop +let increment_global_counter ?counter ?fee ?gas_limit ?storage_limit ctxt + (src : Contract.t) = + manager_operation + ?counter + ?fee + ?gas_limit + ?storage_limit + ~source:src + ctxt + Global_counter_increment + >>=? fun sop -> + Context.Contract.manager ctxt src + >|=? fun account -> sign account.sk ctxt sop + let delegation ?fee ctxt source dst = let top = Delegation dst in manager_operation diff --git a/src/proto_alpha/lib_protocol/test/helpers/op.mli b/src/proto_alpha/lib_protocol/test/helpers/op.mli index 6d569d47eb7..a77d5a52546 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/op.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/op.mli @@ -139,3 +139,12 @@ val ballot : val dummy_script : Script.t val dummy_script_cost : Test_tez.Tez.t + +val increment_global_counter : + ?counter:counter -> + ?fee:Tez.t -> + ?gas_limit:Fixed_point_repr.integral_tag Gas.Arith.t -> + ?storage_limit:counter -> + Context.t -> + Contract.t -> + (packed_operation, error trace) result Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/main.ml b/src/proto_alpha/lib_protocol/test/main.ml index f5aa6fb23b6..95e49ac3e41 100644 --- a/src/proto_alpha/lib_protocol/test/main.ml +++ b/src/proto_alpha/lib_protocol/test/main.ml @@ -63,5 +63,6 @@ let () = ("constants", Test_constants.tests); ("level module", Test_level_module.tests); ("liquidity baking", Test_liquidity_baking.tests); - ("temp big maps", Test_temp_big_maps.tests) ] + ("temp big maps", Test_temp_big_maps.tests); + ("test_global_counter", Test_global_counter.tests) ] |> Lwt_main.run -- GitLab From c4d6e51067277fa74a48fe2a720ccbe955769a48 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Mon, 24 May 2021 17:48:29 +0100 Subject: [PATCH 17/33] Missing file --- .../lib_protocol/test/test_global_counter.ml | 72 +++++++++++++++++++ 1 file changed, 72 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/test/test_global_counter.ml diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml new file mode 100644 index 00000000000..0dfa4a69ab2 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -0,0 +1,72 @@ +open Protocol + +let ( let* ) m f = m >>=? f +let register_contract () = + Context.init 1 + >|=? function (b, [contract]) -> (b, contract) | _ -> assert false + +let global_counter_initially_zero () = + let* (b, _) = register_contract () in + let* inc = Incremental.begin_construction b in + let* n = Context.get_global_counter (I inc) in + Assert.equal_int32 ~loc:__LOC__ 0l n + +let increment_counter_n block contract n = + let gas_limit = + Protocol.Alpha_context.Gas.Arith.integral_of_int_exn 10_000 + in + let rec increment_n n inc = + if n <= 0 then return inc + else + let* op = Op.increment_global_counter ~gas_limit (I inc) contract in + let* inc = Incremental.add_operation inc op in + increment_n (n - 1) inc + in + let* inc = Incremental.begin_construction block in + increment_n n inc + +let increment_global_counter () = + let n = 5 in + let* (b, contract) = register_contract () in + let* inc = increment_counter_n b contract n in + let* count = Context.get_global_counter (I inc) in + Assert.equal_int32 ~loc:__LOC__ count (Int32.of_int n) + +let parse_str str = + Michelson_v1_parser.parse_expression str + |> Micheline_parser.no_parsing_error + >>? fun {Michelson_v1_parser.expanded = v; _} -> + ok @@ Alpha_context.Script.lazy_expr v + +let increment_one_script = + {| {CAR; NIL operation; INCREMENT_GLOBAL_COUNTER; CONS; PAIR;} |} + +let increment_global_counter_from_script () = + let* (block, _) = register_contract () in + let* inc = Incremental.begin_construction block in + Test_interpretation.run_script + (Incremental.alpha_ctxt inc) + ~storage:"Unit" + ~parameter:"0" + increment_one_script + () + >>= function + | Ok _ -> + Alcotest.fail "Expected successful script execution" + | Error _ -> + return () + +let tests = + [ Test_services.tztest + "Global counter is initially zero" + `Quick + global_counter_initially_zero; + Test_services.tztest + "Increment global counter and check value" + `Quick + increment_global_counter; + Test_services.tztest + "Increment global counter updated by executing contract" + `Quick + increment_global_counter_from_script + ] -- GitLab From 4888d4948ed4c9b5fa226a3162e9a33ea8512800 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Mon, 24 May 2021 17:55:35 +0100 Subject: [PATCH 18/33] Minor formatting --- src/proto_alpha/lib_protocol/test/test_global_counter.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index 0dfa4a69ab2..f54776cf06a 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -1,6 +1,7 @@ open Protocol -let ( let* ) m f = m >>=? f +let ( let* ) = (>>=?) + let register_contract () = Context.init 1 >|=? function (b, [contract]) -> (b, contract) | _ -> assert false @@ -68,5 +69,4 @@ let tests = Test_services.tztest "Increment global counter updated by executing contract" `Quick - increment_global_counter_from_script - ] + increment_global_counter_from_script ] -- GitLab From 4641f7f2e106692e061a9360be7beb992328a87e Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 25 May 2021 09:56:50 +0100 Subject: [PATCH 19/33] Scrap let* --- .../lib_protocol/test/test_global_counter.ml | 39 ++++++++++--------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index f54776cf06a..2066ae0e778 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -1,16 +1,16 @@ open Protocol -let ( let* ) = (>>=?) - let register_contract () = Context.init 1 - >|=? function (b, [contract]) -> (b, contract) | _ -> assert false + >|=? function (block, [contract]) -> (block, contract) | _ -> assert false let global_counter_initially_zero () = - let* (b, _) = register_contract () in - let* inc = Incremental.begin_construction b in - let* n = Context.get_global_counter (I inc) in - Assert.equal_int32 ~loc:__LOC__ 0l n + register_contract () + >>=? fun (block, _) -> + Incremental.begin_construction block + >>=? fun inc -> + Context.get_global_counter (I inc) + >>=? fun n -> Assert.equal_int32 ~loc:__LOC__ 0l n let increment_counter_n block contract n = let gas_limit = @@ -19,19 +19,20 @@ let increment_counter_n block contract n = let rec increment_n n inc = if n <= 0 then return inc else - let* op = Op.increment_global_counter ~gas_limit (I inc) contract in - let* inc = Incremental.add_operation inc op in - increment_n (n - 1) inc + Op.increment_global_counter ~gas_limit (I inc) contract + >>=? fun op -> + Incremental.add_operation inc op >>=? fun inc -> increment_n (n - 1) inc in - let* inc = Incremental.begin_construction block in - increment_n n inc + Incremental.begin_construction block >>=? increment_n n let increment_global_counter () = let n = 5 in - let* (b, contract) = register_contract () in - let* inc = increment_counter_n b contract n in - let* count = Context.get_global_counter (I inc) in - Assert.equal_int32 ~loc:__LOC__ count (Int32.of_int n) + register_contract () + >>=? fun (block, contract) -> + increment_counter_n block contract n + >>=? fun inc -> + Context.get_global_counter (I inc) + >>=? fun count -> Assert.equal_int32 ~loc:__LOC__ count (Int32.of_int n) let parse_str str = Michelson_v1_parser.parse_expression str @@ -43,8 +44,10 @@ let increment_one_script = {| {CAR; NIL operation; INCREMENT_GLOBAL_COUNTER; CONS; PAIR;} |} let increment_global_counter_from_script () = - let* (block, _) = register_contract () in - let* inc = Incremental.begin_construction block in + register_contract () + >>=? fun (block, _) -> + Incremental.begin_construction block + >>=? fun inc -> Test_interpretation.run_script (Incremental.alpha_ctxt inc) ~storage:"Unit" -- GitLab From 58a38a2b6224a05ea8475e6fb9f8488c7cd1d08c Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 25 May 2021 12:24:43 +0100 Subject: [PATCH 20/33] Test calling contract endpoint --- .../lib_protocol/test/test_global_counter.ml | 93 ++++++++++++------- 1 file changed, 58 insertions(+), 35 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index 2066ae0e778..9c8ae50b227 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -1,9 +1,60 @@ -open Protocol +module AC = Protocol.Alpha_context let register_contract () = Context.init 1 >|=? function (block, [contract]) -> (block, contract) | _ -> assert false +let make_contract ~code ~originator ~amount ~block = + let code = AC.Script.lazy_expr @@ Expr.from_string code in + let amount = AC.Tez.of_mutez_exn (Int64.of_int amount) in + Incremental.begin_construction block + >>=? fun b -> + let script = Op.{dummy_script with code} in + Op.origination (I b) originator ~script ~credit:amount + >>=? fun (op, originated_contract) -> + Incremental.add_operation b op + >>=? fun b -> + Incremental.finalize_block b + >>=? fun b -> Error_monad.return (b, originated_contract) + +let transfer block ~sender ~recipient ~amount ~entrypoint = + Incremental.begin_construction block + >>=? fun block -> + Op.transaction + (I block) + ~entrypoint + ~fee:AC.Tez.zero + sender + recipient + (AC.Tez.of_mutez_exn amount) + >>=? Incremental.add_operation block + >>=? Incremental.finalize_block + +let call_contract_with_increment_global_counater () = + register_contract () + >>=? fun (block, originator) -> + let code = + {| + {parameter unit; + storage unit; + code { + CAR; + NIL operation; + INCREMENT_GLOBAL_COUNTER; + CONS; PAIR; + } + } + |} + in + make_contract ~code ~originator ~amount:0 ~block + >>=? fun (block, recipient) -> + transfer block ~sender:originator ~recipient ~amount:0L ~entrypoint:"default" + >>=? fun block -> + Incremental.begin_construction block + >>=? fun inc -> + Context.get_global_counter (I inc) + >>=? fun n -> Assert.equal_int32 ~loc:__LOC__ 1l n + let global_counter_initially_zero () = register_contract () >>=? fun (block, _) -> @@ -12,10 +63,8 @@ let global_counter_initially_zero () = Context.get_global_counter (I inc) >>=? fun n -> Assert.equal_int32 ~loc:__LOC__ 0l n -let increment_counter_n block contract n = - let gas_limit = - Protocol.Alpha_context.Gas.Arith.integral_of_int_exn 10_000 - in +let repeat_increment_counter block contract n = + let gas_limit = AC.Gas.Arith.integral_of_int_exn 10_000 in let rec increment_n n inc = if n <= 0 then return inc else @@ -26,40 +75,14 @@ let increment_counter_n block contract n = Incremental.begin_construction block >>=? increment_n n let increment_global_counter () = - let n = 5 in + let n = 3 in register_contract () >>=? fun (block, contract) -> - increment_counter_n block contract n + repeat_increment_counter block contract n >>=? fun inc -> Context.get_global_counter (I inc) >>=? fun count -> Assert.equal_int32 ~loc:__LOC__ count (Int32.of_int n) -let parse_str str = - Michelson_v1_parser.parse_expression str - |> Micheline_parser.no_parsing_error - >>? fun {Michelson_v1_parser.expanded = v; _} -> - ok @@ Alpha_context.Script.lazy_expr v - -let increment_one_script = - {| {CAR; NIL operation; INCREMENT_GLOBAL_COUNTER; CONS; PAIR;} |} - -let increment_global_counter_from_script () = - register_contract () - >>=? fun (block, _) -> - Incremental.begin_construction block - >>=? fun inc -> - Test_interpretation.run_script - (Incremental.alpha_ctxt inc) - ~storage:"Unit" - ~parameter:"0" - increment_one_script - () - >>= function - | Ok _ -> - Alcotest.fail "Expected successful script execution" - | Error _ -> - return () - let tests = [ Test_services.tztest "Global counter is initially zero" @@ -70,6 +93,6 @@ let tests = `Quick increment_global_counter; Test_services.tztest - "Increment global counter updated by executing contract" + "Call contract with increment-global-counter instruction" `Quick - increment_global_counter_from_script ] + call_contract_with_increment_global_counater ] -- GitLab From 85c3dde845a253106f6dd79e62f72a8f15541659 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 25 May 2021 15:59:21 +0100 Subject: [PATCH 21/33] Rebase in progress --- .../lib_protocol/michelson_v1_gas.ml | 42 +- .../lib_protocol/script_interpreter.ml | 1256 ++++++----------- .../lib_protocol/script_interpreter_defs.ml | 2 + .../lib_protocol/script_ir_translator.ml | 2 +- .../lib_protocol/script_typed_ir.ml | 8 +- 5 files changed, 439 insertions(+), 871 deletions(-) diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index bb7b832b988..207401a8683 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -1368,7 +1368,8 @@ module Cost_of = struct (int_bytes ticket_a.amount) (int_bytes ticket_b.amount)) - let increment_global_counter = atomic_step_cost cost_N_IIncrement_global_counter_key + (* TODO: Joel what to set the gas cost to? *) + let increment_global_counter = S.safe_int 100 (* Continuations *) module Control = struct @@ -1584,43 +1585,6 @@ module Cost_of = struct atomic_step_cost S.(add (S.safe_int 100) (S.ediv total_bytes (S.safe_int 10))) - (* Cost of additional call to logger + overhead of setting up call to [interp]. *) - let exec = atomic_step_cost (S.safe_int 100) - - (* Heavy computation happens in the [unparse_data], [unparse_ty] - functions which are carbonated. We must account for allocating - the Micheline lambda wrapper. *) - let apply = atomic_step_cost (S.safe_int 1000) - - (* Pushing a pointer on the stack. *) - let lambda = push - - (* Pusing an address on the stack. *) - let address = push - - (* Most computation happens in [parse_contract_from_script], which is carbonated. - Account for pushing on the stack. *) - let contract = push - - (* Most computation happens in [collect_lazy_storage], [extract_lazy_storage_diff] - and [unparse_data] which are carbonated. The instruction-specific overhead - is mostly that of updating the internal nonce, which we approximate by the - cost of a push. *) - let transfer_tokens = Gas.(push +@ push) - - (* TODO: Joel: what should be the gas cost? *) - let increment_global_counter = Gas.(push) - - (* Wrapping a value and pushing it on the stack. *) - let implicit_account = push - - (* As for [transfer_token], most computation happens elsewhere. - We still account for the overhead of updating the internal_nonce. *) - let create_contract = Gas.(push +@ push) - - (* Increments the internal_nonce counter. *) - let set_delegate = Gas.(push +@ push) - (* Cost of access taken care of in Contract_storage.get_balance_carbonated *) let balance = Gas.free @@ -1859,4 +1823,4 @@ module Cost_of = struct let cms = List.length d.commitments_and_ciphertexts in atomic_step_cost (cost_SAPLING_DIFF_ENCODING ~nfs ~cms) end -end +end \ No newline at end of file diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index dbdb81d6c3a..b414082ff50 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -235,385 +235,150 @@ let () = group focuses on the evaluation of continuations while the second group is about evaluating the instructions. -let cost_of_instr : type b a. (b, a) descr -> b -> Gas.cost = - fun descr stack -> - match (descr.instr, stack) with - | (Drop, _) -> - Interp_costs.drop - | (Dup, _) -> - Interp_costs.dup - | (Swap, _) -> - Interp_costs.swap - | (Const _, _) -> - Interp_costs.push - | (Cons_some, _) -> - Interp_costs.cons_some - | (Cons_none _, _) -> - Interp_costs.cons_none - | (If_none _, _) -> - Interp_costs.if_none - | (Cons_pair, _) -> - Interp_costs.cons_pair - | (Unpair, _) -> - Interp_costs.unpair - | (Car, _) -> - Interp_costs.car - | (Cdr, _) -> - Interp_costs.cdr - | (Cons_left, _) -> - Interp_costs.cons_left - | (Cons_right, _) -> - Interp_costs.cons_right - | (If_left _, _) -> - Interp_costs.if_left - | (Cons_list, _) -> - Interp_costs.cons_list - | (Nil, _) -> - Interp_costs.nil - | (If_cons _, _) -> - Interp_costs.if_cons - | (List_map _, (list, _)) -> - Interp_costs.list_map list - | (List_size, _) -> - Interp_costs.list_size - | (List_iter _, (l, _)) -> - Interp_costs.list_iter l - | (Empty_set _, _) -> - Interp_costs.empty_set - | (Set_iter _, (set, _)) -> - Interp_costs.set_iter set - | (Set_mem, (v, (set, _))) -> - Interp_costs.set_mem v set - | (Set_update, (v, (_, (set, _)))) -> - Interp_costs.set_update v set - | (Set_size, _) -> - Interp_costs.set_size - | (Empty_map _, _) -> - Interp_costs.empty_map - | (Map_map _, (map, _)) -> - Interp_costs.map_map map - | (Map_iter _, (map, _)) -> - Interp_costs.map_iter map - | (Map_mem, (v, (map, _rest))) -> - Interp_costs.map_mem v map - | (Map_get, (v, (map, _rest))) -> - Interp_costs.map_get v map - | (Map_update, (k, (_, (map, _)))) -> - Interp_costs.map_update k map - | (Map_get_and_update, (k, (_, (map, _)))) -> - Interp_costs.map_get_and_update k map - | (Map_size, _) -> - Interp_costs.map_size - | (Empty_big_map _, _) -> - Interp_costs.empty_map - | (Big_map_mem, (_, (map, _))) -> - Interp_costs.big_map_mem map.diff - | (Big_map_get, (_, (map, _))) -> - Interp_costs.big_map_get map.diff - | (Big_map_update, (_, (_, (map, _)))) -> - Interp_costs.big_map_update map.diff - | (Big_map_get_and_update, (_, (_, (map, _)))) -> - Interp_costs.big_map_get_and_update map.diff - | (Add_seconds_to_timestamp, (n, (t, _))) -> - Interp_costs.add_seconds_timestamp n t - | (Add_timestamp_to_seconds, (t, (n, _))) -> - Interp_costs.add_seconds_timestamp n t - | (Sub_timestamp_seconds, (t, (n, _))) -> - Interp_costs.sub_seconds_timestamp n t - | (Diff_timestamps, (t1, (t2, _))) -> - Interp_costs.diff_timestamps t1 t2 - | (Concat_string_pair, (x, (y, _))) -> - Interp_costs.concat_string_pair x y - | (Concat_string, (ss, _)) -> - Interp_costs.concat_string_precheck ss - | (Slice_string, (_offset, (_length, (s, _)))) -> - Interp_costs.slice_string s - | (String_size, _) -> - Interp_costs.string_size - | (Concat_bytes_pair, (x, (y, _))) -> - Interp_costs.concat_bytes_pair x y - | (Concat_bytes, (ss, _)) -> - Interp_costs.concat_string_precheck ss - | (Slice_bytes, (_offset, (_length, (s, _)))) -> - Interp_costs.slice_bytes s - | (Bytes_size, _) -> - Interp_costs.bytes_size - | (Add_tez, _) -> - Interp_costs.add_tez - | (Sub_tez, _) -> - Interp_costs.sub_tez - | (Mul_teznat, (_, (n, _))) -> - Interp_costs.mul_teznat n - | (Mul_nattez, (n, (_, _))) -> - Interp_costs.mul_teznat n - | (Or, _) -> - Interp_costs.bool_or - | (And, _) -> - Interp_costs.bool_and - | (Xor, _) -> - Interp_costs.bool_xor - | (Not, _) -> - Interp_costs.bool_not - | (Is_nat, _) -> - Interp_costs.is_nat - | (Abs_int, (x, _)) -> - Interp_costs.abs_int x - | (Int_nat, _) -> - Interp_costs.int_nat - | (Neg_int, (x, _)) -> - Interp_costs.neg_int x - | (Neg_nat, (x, _)) -> - Interp_costs.neg_nat x - | (Add_intint, (x, (y, _))) -> - Interp_costs.add_bigint x y - | (Add_intnat, (x, (y, _))) -> - Interp_costs.add_bigint x y - | (Add_natint, (x, (y, _))) -> - Interp_costs.add_bigint x y - | (Add_natnat, (x, (y, _))) -> - Interp_costs.add_bigint x y - | (Sub_int, (x, (y, _))) -> - Interp_costs.sub_bigint x y - | (Mul_intint, (x, (y, _))) -> - Interp_costs.mul_bigint x y - | (Mul_intnat, (x, (y, _))) -> - Interp_costs.mul_bigint x y - | (Mul_natint, (x, (y, _))) -> - Interp_costs.mul_bigint x y - | (Mul_natnat, (x, (y, _))) -> - Interp_costs.mul_bigint x y - | (Ediv_teznat, (x, (y, _))) -> - Interp_costs.ediv_teznat x y - | (Ediv_tez, _) -> - Interp_costs.ediv_tez - | (Ediv_intint, (x, (y, _))) -> - Interp_costs.ediv_bigint x y - | (Ediv_intnat, (x, (y, _))) -> - Interp_costs.ediv_bigint x y - | (Ediv_natint, (x, (y, _))) -> - Interp_costs.ediv_bigint x y - | (Ediv_natnat, (x, (y, _))) -> - Interp_costs.ediv_bigint x y - | (Lsl_nat, (x, _)) -> - Interp_costs.lsl_nat x - | (Lsr_nat, (x, _)) -> - Interp_costs.lsr_nat x - | (Or_nat, (x, (y, _))) -> - Interp_costs.or_nat x y - | (And_nat, (x, (y, _))) -> - Interp_costs.and_nat x y - | (And_int_nat, (x, (y, _))) -> - Interp_costs.and_nat x y - | (Xor_nat, (x, (y, _))) -> - Interp_costs.xor_nat x y - | (Not_int, (x, _)) -> - Interp_costs.not_nat x - | (Not_nat, (x, _)) -> - Interp_costs.not_nat x - | (Seq _, _) -> - Interp_costs.seq - | (If _, _) -> - Interp_costs.if_ - | (Loop _, _) -> - Interp_costs.loop - | (Loop_left _, _) -> - Interp_costs.loop_left - | (Dip _, _) -> - Interp_costs.dip - | (Exec, _) -> - Interp_costs.exec - | (Apply _, _) -> - Interp_costs.apply - | (Lambda _, _) -> - Interp_costs.push - | (Failwith _, _) -> - Gas.free - | (Nop, _) -> - Interp_costs.nop - | (Compare ty, (a, (b, _))) -> - Interp_costs.compare ty a b - | (Eq, _) -> - Interp_costs.neq - | (Neq, _) -> - Interp_costs.neq - | (Lt, _) -> - Interp_costs.neq - | (Le, _) -> - Interp_costs.neq - | (Gt, _) -> - Interp_costs.neq - | (Ge, _) -> - Interp_costs.neq - | (Pack _, _) -> - Gas.free - | (Unpack _, _) -> - Gas.free - | (Address, _) -> - Interp_costs.address - | (Contract _, _) -> - Interp_costs.contract - | (Transfer_tokens, _) -> - Interp_costs.transfer_tokens - | (Increment_global_counter, _) -> - Interp_costs.increment_global_counter - | (Implicit_account, _) -> - Interp_costs.implicit_account - | (Set_delegate, _) -> - Interp_costs.set_delegate - | (Balance, _) -> - Interp_costs.balance - | (Level, _) -> - Interp_costs.level - | (Now, _) -> - Interp_costs.now - | (Check_signature, (key, (_, (message, _)))) -> - Interp_costs.check_signature key message - | (Hash_key, (pk, _)) -> - Interp_costs.hash_key pk - | (Blake2b, (bytes, _)) -> - Interp_costs.blake2b bytes - | (Sha256, (bytes, _)) -> - Interp_costs.sha256 bytes - | (Sha512, (bytes, _)) -> - Interp_costs.sha512 bytes - | (Source, _) -> - Interp_costs.source - | (Sender, _) -> - Interp_costs.source - | (Self _, _) -> - Interp_costs.self - | (Self_address, _) -> - Interp_costs.self - | (Amount, _) -> - Interp_costs.amount - | (Dig (n, _), _) -> - Interp_costs.dign n - | (Dug (n, _), _) -> - Interp_costs.dugn n - | (Dipn (n, _, _), _) -> - Interp_costs.dipn n - | (Dropn (n, _), _) -> - Interp_costs.dropn n - | (ChainId, _) -> - Interp_costs.chain_id - | (Create_contract _, _) -> - Interp_costs.create_contract - | (Never, (_, _)) -> - . - | (Voting_power, _) -> - Interp_costs.voting_power - | (Total_voting_power, _) -> - Interp_costs.total_voting_power - | (Keccak, (bytes, _)) -> - Interp_costs.keccak bytes - | (Sha3, (bytes, _)) -> - Interp_costs.sha3 bytes - | (Add_bls12_381_g1, _) -> - Interp_costs.add_bls12_381_g1 - | (Add_bls12_381_g2, _) -> - Interp_costs.add_bls12_381_g2 - | (Add_bls12_381_fr, _) -> - Interp_costs.add_bls12_381_fr - | (Mul_bls12_381_g1, _) -> - Interp_costs.mul_bls12_381_g1 - | (Mul_bls12_381_g2, _) -> - Interp_costs.mul_bls12_381_g2 - | (Mul_bls12_381_fr, _) -> - Interp_costs.mul_bls12_381_fr - | (Mul_bls12_381_fr_z, _) -> - Interp_costs.mul_bls12_381_fr_z - | (Mul_bls12_381_z_fr, _) -> - Interp_costs.mul_bls12_381_fr_z - | (Int_bls12_381_fr, _) -> - Interp_costs.int_bls12_381_fr - | (Neg_bls12_381_g1, _) -> - Interp_costs.neg_bls12_381_g1 - | (Neg_bls12_381_g2, _) -> - Interp_costs.neg_bls12_381_g2 - | (Neg_bls12_381_fr, _) -> - Interp_costs.neg_bls12_381_fr - | (Pairing_check_bls12_381, (pairs, _)) -> - Interp_costs.pairing_check_bls12_381 pairs - | (Comb (n, _), _) -> - Interp_costs.comb n - | (Uncomb (n, _), _) -> - Interp_costs.uncomb n - | (Comb_get (n, _), _) -> - Interp_costs.comb_get n - | (Comb_set (n, _), _) -> - Interp_costs.comb_set n - | (Dup_n (n, _), _) -> - Interp_costs.dupn n - | (Sapling_empty_state _, _) -> - Interp_costs.sapling_empty_state - | (Sapling_verify_update, (tx, _)) -> - let inputs = List.length tx.inputs in - let outputs = List.length tx.outputs in - Interp_costs.sapling_verify_update ~inputs ~outputs - | (Ticket, _) -> - Interp_costs.ticket - | (Read_ticket, _) -> - Interp_costs.read_ticket - | (Split_ticket, (ticket, ((amount_a, amount_b), _))) -> - Interp_costs.split_ticket ticket.amount amount_a amount_b - | (Join_tickets ty, ((ticket_a, ticket_b), _)) -> - Interp_costs.join_tickets ty ticket_a ticket_b - -let unpack ctxt ~ty ~bytes = - Gas.check_enough ctxt (Script.serialized_cost bytes) - >>?= fun () -> - if - Compare.Int.(Bytes.length bytes >= 1) - && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05) - then - let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> - Lwt.return - ( Gas.consume ctxt (Interp_costs.unpack_failed bytes) - >|? fun ctxt -> (None, ctxt) ) - | Some expr -> ( - Gas.consume ctxt (Script.deserialized_cost expr) - >>?= fun ctxt -> - parse_data - ctxt - ~legacy:false - ~allow_forged:false - ty - (Micheline.root expr) - >|= function - | Ok (value, ctxt) -> - ok (Some value, ctxt) - | Error _ignored -> - Gas.consume ctxt (Interp_costs.unpack_failed bytes) - >|? fun ctxt -> (None, ctxt) ) - else return (None, ctxt) - -let rec step_bounded : - type b a. - logger -> - stack_depth:int -> - context -> - step_constants -> - (b, a) descr -> - b -> - (a * context) tzresult Lwt.t = - fun logger ~stack_depth ctxt step_constants ({instr; loc; _} as descr) stack -> - let gas = cost_of_instr descr stack in - Gas.consume ctxt gas - >>?= fun ctxt -> - let module Log = (val logger) in - Log.log_entry ctxt descr stack ; - let logged_return : a * context -> (a * context) tzresult Lwt.t = - fun (ret, ctxt) -> - Log.log_exit ctxt descr ret ; - return (ret, ctxt) - in - let non_terminal_recursion ~ctxt ?(stack_depth = stack_depth + 1) descr stack - = - if Compare.Int.(stack_depth >= 10_000) then - fail Michelson_too_many_recursive_calls - else step_bounded logger ~stack_depth ctxt step_constants descr stack +*) + +(* + + Evaluation of continuations + =========================== + + As explained in [Script_typed_ir], there are several kinds of + continuations, each having a specific evaluation rules. The + following group of functions starts with a list of evaluation + rules for continuations that generate fresh continuations. This + group ends with the definition of [next], which dispatches + evaluation rules depending on the continuation at stake. + + *) +let rec kmap_exit : + type a b c d e f g h m n o. + (a, b, c, d, e, f, g, h, m, n, o) kmap_exit_type = + fun mk g gas (body, xs, ys, yk) ks accu stack -> + let ys = map_update yk (Some accu) ys in + let ks = mk (KMap_enter_body (body, xs, ys, ks)) in + let (accu, stack) = stack in + (next [@ocaml.tailcall]) g gas ks accu stack + [@@inline] + +and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = + fun mk g gas body xs ys ks accu stack -> + match xs with + | [] -> + (next [@ocaml.tailcall]) g gas ks ys (accu, stack) + | (xk, xv) :: xs -> + let ks = mk (KMap_exit_body (body, xs, ys, xk, ks)) in + let res = (xk, xv) in + let stack = (accu, stack) in + (step [@ocaml.tailcall]) g gas body ks res stack + [@@inline] + +and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = + fun mk g gas (body, xs, ys, len) ks accu stack -> + let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in + let (accu, stack) = stack in + (next [@ocaml.tailcall]) g gas ks accu stack + [@@inline] + +and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = + fun mk g gas (body, xs, ys, len) ks' accu stack -> + match xs with + | [] -> + let ys = {elements = List.rev ys; length = len} in + (next [@ocaml.tailcall]) g gas ks' ys (accu, stack) + | x :: xs -> + let ks = mk (KList_exit_body (body, xs, ys, len, ks')) in + (step [@ocaml.tailcall]) g gas body ks x (accu, stack) + [@@inline] + +and kloop_in_left : + type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = + fun g gas ks0 ki ks' accu stack -> + match accu with + | L v -> + (step [@ocaml.tailcall]) g gas ki ks0 v stack + | R v -> + (next [@ocaml.tailcall]) g gas ks' v stack + [@@inline] + +and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = + fun g gas ks0 ki ks' accu stack -> + let (accu', stack') = stack in + if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' + else (next [@ocaml.tailcall]) g gas ks' accu' stack' + [@@inline] + +and kiter : type a b s r f. (a, b, s, r, f) kiter_type = + fun mk g gas body xs ks accu stack -> + match xs with + | [] -> + (next [@ocaml.tailcall]) g gas ks accu stack + | x :: xs -> + let ks = mk (KIter (body, xs, ks)) in + (step [@ocaml.tailcall]) g gas body ks x (accu, stack) + [@@inline] + +and next : + type a s r f. + outdated_context * step_constants -> + local_gas_counter -> + (a, s, r, f) continuation -> + a -> + s -> + (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = + fun ((ctxt, _) as g) gas ks0 accu stack -> + match consume_control gas ks0 with + | None -> + Lwt.return (Gas.gas_exhausted_error (update_context gas ctxt)) + | Some gas -> ( + match ks0 with + | KLog (ks, logger) -> + (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack + | KNil -> + Lwt.return (Ok (accu, stack, ctxt, gas)) + | KCons (k, ks) -> + (step [@ocaml.tailcall]) g gas k ks accu stack + | KLoop_in (ki, ks') -> + (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack + | KReturn (stack', ks) -> + (next [@ocaml.tailcall]) g gas ks accu stack' + | KLoop_in_left (ki, ks') -> + (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack + | KUndip (x, ks) -> + (next [@ocaml.tailcall]) g gas ks x (accu, stack) + | KIter (body, xs, ks) -> + (kiter [@ocaml.tailcall]) id g gas body xs ks accu stack + | KList_enter_body (body, xs, ys, len, ks) -> + let extra = (body, xs, ys, len) in + (klist_enter [@ocaml.tailcall]) id g gas extra ks accu stack + | KList_exit_body (body, xs, ys, len, ks) -> + let extra = (body, xs, ys, len) in + (klist_exit [@ocaml.tailcall]) id g gas extra ks accu stack + | KMap_enter_body (body, xs, ys, ks) -> + (kmap_enter [@ocaml.tailcall]) id g gas body xs ys ks accu stack + | KMap_exit_body (body, xs, ys, yk, ks) -> + let extra = (body, xs, ys, yk) in + (kmap_exit [@ocaml.tailcall]) id g gas extra ks accu stack ) + +(* + + Evaluation of instructions + ========================== + + The following functions define evaluation rules for instructions that + generate fresh continuations. As such, they expect a constructor + [log_if_needed] which inserts a [KLog] if the evaluation is logged. + + The [step] function is taking care of the evaluation of the other + instructions. + +*) +and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = + fun log_if_needed g gas body k ks accu stack -> + let xs = accu.elements in + let ys = [] in + let len = accu.length in + let ks = + log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks))) in let (accu, stack) = stack in (next [@ocaml.tailcall]) g gas ks accu stack @@ -1093,454 +858,258 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = match Script_int.to_int64 r with | None -> assert false (* Cannot overflow *) - | Some r -> - Some (q, r) ) ) - in - logged_return ((result, rest), ctxt) - | (Ediv_intint, (x, (y, rest))) -> - logged_return ((Script_int.ediv x y, rest), ctxt) - | (Ediv_intnat, (x, (y, rest))) -> - logged_return ((Script_int.ediv x y, rest), ctxt) - | (Ediv_natint, (x, (y, rest))) -> - logged_return ((Script_int.ediv x y, rest), ctxt) - | (Ediv_natnat, (x, (y, rest))) -> - logged_return ((Script_int.ediv_n x y, rest), ctxt) - | (Lsl_nat, (x, (y, rest))) -> ( - match Script_int.shift_left_n x y with - | None -> - Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) - | Some x -> - logged_return ((x, rest), ctxt) ) - | (Lsr_nat, (x, (y, rest))) -> ( - match Script_int.shift_right_n x y with - | None -> - Log.get_log () >>=? fun log -> fail (Overflow (loc, log)) - | Some r -> - logged_return ((r, rest), ctxt) ) - | (Or_nat, (x, (y, rest))) -> - logged_return ((Script_int.logor x y, rest), ctxt) - | (And_nat, (x, (y, rest))) -> - logged_return ((Script_int.logand x y, rest), ctxt) - | (And_int_nat, (x, (y, rest))) -> - logged_return ((Script_int.logand x y, rest), ctxt) - | (Xor_nat, (x, (y, rest))) -> - logged_return ((Script_int.logxor x y, rest), ctxt) - | (Not_int, (x, rest)) -> - logged_return ((Script_int.lognot x, rest), ctxt) - | (Not_nat, (x, rest)) -> - logged_return ((Script_int.lognot x, rest), ctxt) - (* control *) - | (Seq (hd, tl), stack) -> - non_terminal_recursion ~ctxt hd stack - >>=? fun (trans, ctxt) -> - step_bounded logger ~stack_depth ctxt step_constants tl trans - | (If (bt, _), (true, rest)) -> - step_bounded logger ~stack_depth ctxt step_constants bt rest - | (If (_, bf), (false, rest)) -> - step_bounded logger ~stack_depth ctxt step_constants bf rest - | (Loop body, (true, rest)) -> - non_terminal_recursion ~ctxt body rest - >>=? fun (trans, ctxt) -> - step_bounded logger ~stack_depth ctxt step_constants descr trans - | (Loop _, (false, rest)) -> - logged_return (rest, ctxt) - | (Loop_left body, (L v, rest)) -> - non_terminal_recursion ~ctxt body (v, rest) - >>=? fun (trans, ctxt) -> - step_bounded logger ~stack_depth ctxt step_constants descr trans - | (Loop_left _, (R v, rest)) -> - logged_return ((v, rest), ctxt) - | (Dip b, (ign, rest)) -> - non_terminal_recursion ~ctxt b rest - >>=? fun (res, ctxt) -> logged_return ((ign, res), ctxt) - | (Exec, (arg, (Lam (code, _), rest))) -> - Log.log_interp ctxt code (arg, ()) ; - non_terminal_recursion ~ctxt code (arg, ()) - >>=? fun ((res, ()), ctxt) -> logged_return ((res, rest), ctxt) - | (Apply capture_ty, (capture, (lam, rest))) -> ( - let (Lam (descr, expr)) = lam in - let (Item_t (full_arg_ty, _, _)) = descr.bef in - unparse_data ctxt Optimized capture_ty capture - >>=? fun (const_expr, ctxt) -> - unparse_ty ctxt capture_ty - >>?= fun (ty_expr, ctxt) -> - match full_arg_ty with - | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _) -> - let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in - let const_descr = - ( { - loc = descr.loc; - bef = arg_stack_ty; - aft = Item_t (capture_ty, arg_stack_ty, None); - instr = Const capture; - } - : (_, _) descr ) - in - let pair_descr = - ( { - loc = descr.loc; - bef = Item_t (capture_ty, arg_stack_ty, None); - aft = Item_t (full_arg_ty, Empty_t, None); - instr = Cons_pair; - } - : (_, _) descr ) - in - let seq_descr = - ( { - loc = descr.loc; - bef = arg_stack_ty; - aft = Item_t (full_arg_ty, Empty_t, None); - instr = Seq (const_descr, pair_descr); - } - : (_, _) descr ) - in - let full_descr = - ( { - loc = descr.loc; - bef = arg_stack_ty; - aft = descr.aft; - instr = Seq (seq_descr, descr); - } - : (_, _) descr ) - in - let full_expr = - Micheline.Seq - ( 0, - [ Prim (0, I_PUSH, [ty_expr; const_expr], []); - Prim (0, I_PAIR, [], []); - expr ] ) - in - let lam' = Lam (full_descr, full_expr) in - logged_return ((lam', rest), ctxt) - | _ -> - assert false ) - | (Lambda lam, rest) -> - logged_return ((lam, rest), ctxt) - | (Failwith tv, (v, _)) -> - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) - >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - Log.get_log () >>=? fun log -> fail (Reject (loc, v, log)) - | (Nop, stack) -> - logged_return (stack, ctxt) - (* comparison *) - | (Compare ty, (a, (b, rest))) -> - logged_return - ( ( Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b, - rest ), - ctxt ) - (* comparators *) - | (Eq, (cmpres, rest)) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres = 0) in - logged_return ((cmpres, rest), ctxt) - | (Neq, (cmpres, rest)) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <> 0) in - logged_return ((cmpres, rest), ctxt) - | (Lt, (cmpres, rest)) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres < 0) in - logged_return ((cmpres, rest), ctxt) - | (Le, (cmpres, rest)) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres <= 0) in - logged_return ((cmpres, rest), ctxt) - | (Gt, (cmpres, rest)) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres > 0) in - logged_return ((cmpres, rest), ctxt) - | (Ge, (cmpres, rest)) -> - let cmpres = Script_int.compare cmpres Script_int.zero in - let cmpres = Compare.Int.(cmpres >= 0) in - logged_return ((cmpres, rest), ctxt) - (* packing *) - | (Pack t, (value, rest)) -> - Script_ir_translator.pack_data ctxt t value - >>=? fun (bytes, ctxt) -> logged_return ((bytes, rest), ctxt) - | (Unpack ty, (bytes, rest)) -> - unpack ctxt ~ty ~bytes - >>=? fun (opt, ctxt) -> logged_return ((opt, rest), ctxt) - (* protocol *) - | (Address, ((_, address), rest)) -> - logged_return ((address, rest), ctxt) - | (Contract (t, entrypoint), (contract, rest)) -> ( - match (contract, entrypoint) with - | ((contract, "default"), entrypoint) | ((contract, entrypoint), "default") - -> - Script_ir_translator.parse_contract_for_script - ctxt - loc - t - contract - ~entrypoint - >>=? fun (ctxt, maybe_contract) -> - logged_return ((maybe_contract, rest), ctxt) - | _ -> - logged_return ((None, rest), ctxt) ) - | (Transfer_tokens, (p, (amount, ((tp, (destination, entrypoint)), rest)))) - -> - collect_lazy_storage ctxt tp p - >>?= fun (to_duplicate, ctxt) -> - let to_update = no_lazy_storage_id in - extract_lazy_storage_diff - ctxt - Optimized - tp - p - ~to_duplicate - ~to_update - ~temporary:true - >>=? fun (p, lazy_storage_diff, ctxt) -> - unparse_data ctxt Optimized tp p - >>=? fun (p, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost p) - >>?= fun ctxt -> - let operation = - Transaction - { - amount; - destination; - entrypoint; - parameters = Script.lazy_expr (Micheline.strip_locations p); - } - in - fresh_internal_nonce ctxt - >>?= fun (ctxt, nonce) -> - let packed_op = - Internal_operation {source = step_constants.self; operation; nonce} - in - logged_return (((packed_op, lazy_storage_diff), rest), ctxt) - | (Increment_global_counter, rest) -> - fresh_internal_nonce ctxt - >>?= fun (ctxt, nonce) -> - let operation = - Internal_operation - { - source = step_constants.self; - operation = Global_counter_increment; - nonce; - } - in - logged_return (((operation, None), rest), ctxt) - | (Implicit_account, (key, rest)) -> - let contract = Contract.implicit_contract key in - logged_return (((Unit_t None, (contract, "default")), rest), ctxt) - | ( Create_contract (storage_type, param_type, Lam (_, code), root_name), - (* Removed the instruction's arguments manager, spendable and delegatable *) - (delegate, (credit, (init, rest))) ) -> - unparse_ty ctxt param_type - >>?= fun (unparsed_param_type, ctxt) -> - let unparsed_param_type = - Script_ir_translator.add_field_annot root_name None unparsed_param_type - in - unparse_ty ctxt storage_type - >>?= fun (unparsed_storage_type, ctxt) -> - let code = - Micheline.strip_locations - (Seq - ( 0, - [ Prim (0, K_parameter, [unparsed_param_type], []); - Prim (0, K_storage, [unparsed_storage_type], []); - Prim (0, K_code, [code], []) ] )) - in - collect_lazy_storage ctxt storage_type init - >>?= fun (to_duplicate, ctxt) -> - let to_update = no_lazy_storage_id in - extract_lazy_storage_diff - ctxt - Optimized - storage_type - init - ~to_duplicate - ~to_update - ~temporary:true - >>=? fun (init, lazy_storage_diff, ctxt) -> - unparse_data ctxt Optimized storage_type init - >>=? fun (storage, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost storage) - >>?= fun ctxt -> - let storage = Micheline.strip_locations storage in - Contract.fresh_contract_from_current_nonce ctxt - >>?= fun (ctxt, contract) -> - let operation = - Origination - { - credit; - delegate; - preorigination = Some contract; - script = - { - code = Script.lazy_expr code; - storage = Script.lazy_expr storage; - }; - } - in - fresh_internal_nonce ctxt - >>?= fun (ctxt, nonce) -> - logged_return - ( ( ( Internal_operation - {source = step_constants.self; operation; nonce}, - lazy_storage_diff ), - ((contract, "default"), rest) ), - ctxt ) - | (Set_delegate, (delegate, rest)) -> - let operation = Delegation delegate in - fresh_internal_nonce ctxt - >>?= fun (ctxt, nonce) -> - logged_return - ( ( ( Internal_operation - {source = step_constants.self; operation; nonce}, - None ), - rest ), - ctxt ) - | (Balance, rest) -> - Contract.get_balance_carbonated ctxt step_constants.self - >>=? fun (ctxt, balance) -> logged_return ((balance, rest), ctxt) - | (Level, rest) -> - let level = - (Level.current ctxt).level |> Raw_level.to_int32 |> Script_int.of_int32 - |> Script_int.abs - in - logged_return ((level, rest), ctxt) - | (Now, rest) -> - let now = Script_timestamp.now ctxt in - logged_return ((now, rest), ctxt) - | (Check_signature, (key, (signature, (message, rest)))) -> - let res = Signature.check key signature message in - logged_return ((res, rest), ctxt) - | (Hash_key, (key, rest)) -> - logged_return ((Signature.Public_key.hash key, rest), ctxt) - | (Blake2b, (bytes, rest)) -> - let hash = Raw_hashes.blake2b bytes in - logged_return ((hash, rest), ctxt) - | (Sha256, (bytes, rest)) -> - let hash = Raw_hashes.sha256 bytes in - logged_return ((hash, rest), ctxt) - | (Sha512, (bytes, rest)) -> - let hash = Raw_hashes.sha512 bytes in - logged_return ((hash, rest), ctxt) - | (Source, rest) -> - logged_return (((step_constants.payer, "default"), rest), ctxt) - | (Sender, rest) -> - logged_return (((step_constants.source, "default"), rest), ctxt) - | (Self (t, entrypoint), rest) -> - logged_return (((t, (step_constants.self, entrypoint)), rest), ctxt) - | (Self_address, rest) -> - logged_return (((step_constants.self, "default"), rest), ctxt) - | (Amount, rest) -> - logged_return ((step_constants.amount, rest), ctxt) - | (Dig (_n, n'), stack) -> - interp_stack_prefix_preserving_operation - (fun (v, rest) -> return (rest, v)) - n' - stack - >>=? fun (aft, x) -> logged_return ((x, aft), ctxt) - | (Dug (_n, n'), (v, rest)) -> - interp_stack_prefix_preserving_operation - (fun stk -> return ((v, stk), ())) - n' - rest - >>=? fun (aft, ()) -> logged_return (aft, ctxt) - | (Dipn (n, n', b), stack) -> - interp_stack_prefix_preserving_operation - (fun stk -> - non_terminal_recursion - ~ctxt - b - stk - (* This is a cheap upper bound of the number recursive calls to - `interp_stack_prefix_preserving_operation`, which does - ((n / 16) + log2 (n % 16)) iterations *) - ~stack_depth:(stack_depth + 4 + (n / 16))) - n' - stack - >>=? fun (aft, ctxt') -> logged_return (aft, ctxt') - | (Dropn (_n, n'), stack) -> - interp_stack_prefix_preserving_operation - (fun stk -> return (stk, stk)) - n' - stack - >>=? fun (_, rest) -> logged_return (rest, ctxt) - | (Sapling_empty_state {memo_size}, stack) -> - logged_return ((Sapling.empty_state ~memo_size (), stack), ctxt) - | (Sapling_verify_update, (transaction, (state, rest))) -> ( - let address = Contract.to_b58check step_constants.self in - let chain_id = Chain_id.to_b58check step_constants.chain_id in - let anti_replay = address ^ chain_id in - Sapling.verify_update ctxt state transaction anti_replay - >>=? fun (ctxt, balance_state_opt) -> - match balance_state_opt with - | Some (balance, state) -> - logged_return - ((Some (Script_int.of_int64 balance, state), rest), ctxt) - | None -> - logged_return ((None, rest), ctxt) ) - | (ChainId, rest) -> - logged_return ((step_constants.chain_id, rest), ctxt) - | (Never, (_, _)) -> - . - | (Voting_power, (key_hash, rest)) -> - Vote.get_voting_power ctxt key_hash - >>=? fun (ctxt, rolls) -> - logged_return ((Script_int.(abs (of_int32 rolls)), rest), ctxt) - | (Total_voting_power, rest) -> - Vote.get_total_voting_power ctxt - >>=? fun (ctxt, rolls) -> - logged_return ((Script_int.(abs (of_int32 rolls)), rest), ctxt) - | (Keccak, (bytes, rest)) -> - let hash = Raw_hashes.keccak256 bytes in - logged_return ((hash, rest), ctxt) - | (Sha3, (bytes, rest)) -> - let hash = Raw_hashes.sha3_256 bytes in - logged_return ((hash, rest), ctxt) - | (Add_bls12_381_g1, (x, (y, rest))) -> - logged_return ((Bls12_381.G1.add x y, rest), ctxt) - | (Add_bls12_381_g2, (x, (y, rest))) -> - logged_return ((Bls12_381.G2.add x y, rest), ctxt) - | (Add_bls12_381_fr, (x, (y, rest))) -> - logged_return ((Bls12_381.Fr.add x y, rest), ctxt) - | (Mul_bls12_381_g1, (x, (y, rest))) -> - logged_return ((Bls12_381.G1.mul x y, rest), ctxt) - | (Mul_bls12_381_g2, (x, (y, rest))) -> - logged_return ((Bls12_381.G2.mul x y, rest), ctxt) - | (Mul_bls12_381_fr, (x, (y, rest))) -> - logged_return ((Bls12_381.Fr.mul x y, rest), ctxt) - | (Mul_bls12_381_fr_z, (x, (y, rest))) -> - let x = Bls12_381.Fr.of_z (Script_int.to_zint x) in - let res = (Bls12_381.Fr.mul x y, rest) in - logged_return (res, ctxt) - | (Mul_bls12_381_z_fr, (y, (x, rest))) -> - let x = Bls12_381.Fr.of_z (Script_int.to_zint x) in - let res = (Bls12_381.Fr.mul x y, rest) in - logged_return (res, ctxt) - | (Int_bls12_381_fr, (x, rest)) -> - logged_return ((Script_int.of_zint (Bls12_381.Fr.to_z x), rest), ctxt) - | (Neg_bls12_381_g1, (x, rest)) -> - logged_return ((Bls12_381.G1.negate x, rest), ctxt) - | (Neg_bls12_381_g2, (x, rest)) -> - logged_return ((Bls12_381.G2.negate x, rest), ctxt) - | (Neg_bls12_381_fr, (x, rest)) -> - logged_return ((Bls12_381.Fr.negate x, rest), ctxt) - | (Pairing_check_bls12_381, (pairs, rest)) -> - let check = - match pairs.elements with - | [] -> - true - | pairs -> - Bls12_381.( - miller_loop pairs |> final_exponentiation_opt - |> Option.map Gt.(eq one)) - |> Option.value ~default:false - in - logged_return ((check, rest), ctxt) - | (Comb (_, witness), stack) -> - let rec aux : - type before after. - (before, after) comb_gadt_witness -> before -> after = - fun witness stack -> - match (witness, stack) with - | (Comb_one, stack) -> + | Some r -> ( + match Tez.of_mutez r with + | None -> + assert false (* Cannot overflow *) + | Some r -> + Some (q, r) ) ) + in + (step [@ocaml.tailcall]) g gas k ks result stack + | IEdiv_intint (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.ediv x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | IEdiv_intnat (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.ediv x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | IEdiv_natint (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.ediv x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | IEdiv_natnat (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.ediv_n x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | ILsl_nat (kinfo, k) -> + ilsl_nat None g gas kinfo k ks accu stack + | ILsr_nat (kinfo, k) -> + ilsr_nat None g gas kinfo k ks accu stack + | IOr_nat (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.logor x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | IAnd_nat (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.logand x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | IAnd_int_nat (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.logand x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | IXor_nat (_, k) -> + let x = accu and (y, stack) = stack in + let res = Script_int.logxor x y in + (step [@ocaml.tailcall]) g gas k ks res stack + | INot_int (_, k) -> + let x = accu in + let res = Script_int.lognot x in + (step [@ocaml.tailcall]) g gas k ks res stack + | INot_nat (_, k) -> + let x = accu in + let res = Script_int.lognot x in + (step [@ocaml.tailcall]) g gas k ks res stack + (* control *) + | IIf {branch_if_true; branch_if_false} -> + let (res, stack) = stack in + if accu then (step [@ocaml.tailcall]) g gas branch_if_true ks res stack + else (step [@ocaml.tailcall]) g gas branch_if_false ks res stack + | ILoop (_, body, k) -> + let ks = KLoop_in (body, KCons (k, ks)) in + (next [@ocaml.tailcall]) g gas ks accu stack + | ILoop_left (_, bl, br) -> + let ks = KLoop_in_left (bl, KCons (br, ks)) in + (next [@ocaml.tailcall]) g gas ks accu stack + | IDip (_, b, k) -> + let ign = accu in + let ks = KUndip (ign, KCons (k, ks)) in + let (accu, stack) = stack in + (step [@ocaml.tailcall]) g gas b ks accu stack + | IExec (_, k) -> + iexec None g gas k ks accu stack + | IApply (_, capture_ty, k) -> + let capture = accu in + let (lam, stack) = stack in + apply ctxt gas capture_ty capture lam + >>=? fun (lam', ctxt, gas) -> + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack + | ILambda (_, lam, k) -> + (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) + | IFailwith (_, kloc, tv, _) -> + ifailwith None g gas kloc tv accu + (* comparison *) + | ICompare (_, ty, k) -> + let a = accu in + let (b, stack) = stack in + let r = + Script_int.of_int @@ Script_ir_translator.compare_comparable ty a b + in + (step [@ocaml.tailcall]) g gas k ks r stack + (* comparators *) + | IEq (_, k) -> + let a = accu in + let a = Script_int.compare a Script_int.zero in + let a = Compare.Int.(a = 0) in + (step [@ocaml.tailcall]) g gas k ks a stack + | INeq (_, k) -> + let a = accu in + let a = Script_int.compare a Script_int.zero in + let a = Compare.Int.(a <> 0) in + (step [@ocaml.tailcall]) g gas k ks a stack + | ILt (_, k) -> + let a = accu in + let a = Script_int.compare a Script_int.zero in + let a = Compare.Int.(a < 0) in + (step [@ocaml.tailcall]) g gas k ks a stack + | ILe (_, k) -> + let a = accu in + let a = Script_int.compare a Script_int.zero in + let a = Compare.Int.(a <= 0) in + (step [@ocaml.tailcall]) g gas k ks a stack + | IGt (_, k) -> + let a = accu in + let a = Script_int.compare a Script_int.zero in + let a = Compare.Int.(a > 0) in + (step [@ocaml.tailcall]) g gas k ks a stack + | IGe (_, k) -> + let a = accu in + let a = Script_int.compare a Script_int.zero in + let a = Compare.Int.(a >= 0) in + (step [@ocaml.tailcall]) g gas k ks a stack + (* packing *) + | IPack (_, ty, k) -> + let value = accu in + ( use_gas_counter_in_ctxt ctxt gas + @@ fun ctxt -> Script_ir_translator.pack_data ctxt ty value ) + >>=? fun (bytes, ctxt, gas) -> + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack + | IUnpack (_, ty, k) -> + let bytes = accu in + (use_gas_counter_in_ctxt ctxt gas @@ fun ctxt -> unpack ctxt ~ty ~bytes) + >>=? fun (opt, ctxt, gas) -> + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack + | IAddress (_, k) -> + let (_, address) = accu in + (step [@ocaml.tailcall]) g gas k ks address stack + | IContract (kinfo, t, entrypoint, k) -> ( + let contract = accu in + match (contract, entrypoint) with + | ((contract, "default"), entrypoint) + | ((contract, entrypoint), "default") -> + let ctxt = update_context gas ctxt in + Script_ir_translator.parse_contract_for_script + ctxt + kinfo.iloc + t + contract + ~entrypoint + >>=? fun (ctxt, maybe_contract) -> + let gas = update_local_gas_counter ctxt in + let ctxt = outdated ctxt in + let accu = maybe_contract in + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack + | _ -> + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack ) + | ITransfer_tokens (_, k) -> + let p = accu in + let (amount, ((tp, (destination, entrypoint)), stack)) = stack in + transfer (ctxt, sc) gas amount tp p destination entrypoint + >>=? fun (accu, ctxt, gas) -> + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack + | IImplicit_account (_, k) -> + let key = accu in + let contract = Contract.implicit_contract key in + let res = (Unit_t None, (contract, "default")) in + (step [@ocaml.tailcall]) g gas k ks res stack + | ICreate_contract + {storage_type; arg_type; lambda = Lam (_, code); root_name; k} -> + (* Removed the instruction's arguments manager, spendable and delegatable *) + let delegate = accu in + let (credit, (init, stack)) = stack in + create_contract + g + gas + storage_type + arg_type + code + root_name + delegate + credit + init + >>=? fun (res, contract, ctxt, gas) -> + let stack = ((contract, "default"), stack) in + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack + | ISet_delegate (_, k) -> + let delegate = accu in + let operation = Delegation delegate in + let ctxt = update_context gas ctxt in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + let res = + (Internal_operation {source = sc.self; operation; nonce}, None) + in + let gas = update_local_gas_counter ctxt in + let ctxt = outdated ctxt in + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack + | IBalance (_, k) -> + let ctxt = update_context gas ctxt in + Contract.get_balance_carbonated ctxt sc.self + >>=? fun (ctxt, balance) -> + let gas = update_local_gas_counter ctxt in + let ctxt = outdated ctxt in + let g = (ctxt, sc) in + (step [@ocaml.tailcall]) g gas k ks balance (accu, stack) + | ILevel (_, k) -> + let level = + (Level.current (context_from_outdated_context ctxt)).level + |> Raw_level.to_int32 |> Script_int.of_int32 |> Script_int.abs + in + (step [@ocaml.tailcall]) g gas k ks level (accu, stack) + | INow (_, k) -> + let now = Script_timestamp.now (context_from_outdated_context ctxt) in + (step [@ocaml.tailcall]) g gas k ks now (accu, stack) + | ICheck_signature (_, k) -> + let key = accu and (signature, (message, stack)) = stack in + let res = Signature.check key signature message in + (step [@ocaml.tailcall]) g gas k ks res stack + | IHash_key (_, k) -> + let key = accu in + let res = Signature.Public_key.hash key in + (step [@ocaml.tailcall]) g gas k ks res stack + | IBlake2b (_, k) -> + let bytes = accu in + let hash = Raw_hashes.blake2b bytes in + (step [@ocaml.tailcall]) g gas k ks hash stack + | ISha256 (_, k) -> + let bytes = accu in + let hash = Raw_hashes.sha256 bytes in + (step [@ocaml.tailcall]) g gas k ks hash stack + | ISha512 (_, k) -> + let bytes = accu in + let hash = Raw_hashes.sha512 bytes in + (step [@ocaml.tailcall]) g gas k ks hash stack + | ISource (_, k) -> + let res = (sc.payer, "default") in + (step [@ocaml.tailcall]) g gas k ks res (accu, stack) + | ISender (_, k) -> + let res = (sc.source, "default") in + (step [@ocaml.tailcall]) g gas k ks res (accu, stack) + | ISelf (_, ty, entrypoint, k) -> + let res = (ty, (sc.self, entrypoint)) in + (step [@ocaml.tailcall]) g gas k ks res (accu, stack) + | ISelf_address (_, k) -> + let res = (sc.self, "default") in + (step [@ocaml.tailcall]) g gas k ks res (accu, stack) + | IAmount (_, k) -> + let accu = sc.amount and stack = (accu, stack) in + (step [@ocaml.tailcall]) g gas k ks accu stack + | IDig (_, _n, n', k) -> + let ((accu, stack), x) = + interp_stack_prefix_preserving_operation + (fun v stack -> (stack, v)) + n' + accu stack in let accu = x and stack = (accu, stack) in @@ -1815,7 +1384,36 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = } else None in - (step [@ocaml.tailcall]) g gas k ks result stack ) + (step [@ocaml.tailcall]) g gas k ks result stack + | IIncrement_global_counter _ -> + + + let delegate = accu in + let operation = Delegation delegate in + let ctxt = update_context gas ctxt in + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + let res = + (Internal_operation {source = sc.self; operation; nonce}, None) + in + let gas = update_local_gas_counter ctxt in + let ctxt = outdated ctxt in + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack + + + + + fresh_internal_nonce ctxt + >>?= fun (ctxt, nonce) -> + let operation = + Internal_operation + { + source = step_constants.self; + operation = Global_counter_increment; + nonce; + } + in + logged_return (((operation, None), rest), ctxt)) (* @@ -2107,4 +1705,4 @@ module Internals = struct let step (ctxt, step_constants) gas ks accu stack = internal_step ctxt step_constants gas ks accu stack -end +end \ No newline at end of file diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index c51d6bac651..79df2045d0e 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -438,6 +438,8 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = Interp_costs.read_ticket | ILog _ -> Gas.free + | IIncrement_global_counter _ -> + Interp_costs.increment_global_counter [@@ocaml.inline always] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index cfc3dea9493..60e45da3259 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5894,6 +5894,7 @@ and parse_instr : let stack = Item_t (Option_t (ty, None), rest, annot) in typed ctxt 0 loc instr stack | _ -> + (* TODO: fix injectivity of types *) assert false) | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), rest) -> parse_var_annot loc annot >>?= fun annot -> @@ -5902,7 +5903,6 @@ and parse_instr : loc Increment_global_counter (Item_t (Operation_t None, rest, annot)) - (* TODO: fix injectivity of types *) assert false ) (* Primitive parsing errors *) | ( Prim ( loc, diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 16c43e76bc3..9759aa9f428 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -935,7 +935,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | ILog : ('a, 's) kinfo * logging_event * logger * ('a, 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr - | IIncrement_global_counter : ('rest, operation * 'rest) instr + | IIncrement_global_counter : ('a, 's) kinfo -> ('a, 's, 'r, operation * 'r) kinstr and logging_event = | LogEntry : logging_event @@ -1572,6 +1572,8 @@ let kinfo_of_kinstr : type a s b f. (a, s, b, f) kinstr -> (a, s) kinfo = kinfo | ILog (kinfo, _, _, _) -> kinfo + | IIncrement_global_counter kinfo -> + kinfo type kinstr_rewritek = { apply : 'b 'u 'r 'f. ('b, 'u, 'r, 'f) kinstr -> ('b, 'u, 'r, 'f) kinstr; @@ -1906,4 +1908,6 @@ let kinstr_rewritek : | IHalt kinfo -> IHalt kinfo | ILog (kinfo, event, logger, k) -> - ILog (kinfo, event, logger, k) \ No newline at end of file + ILog (kinfo, event, logger, k) + | IIncrement_global_counter kinfo -> + IIncrement_global_counter kinfo \ No newline at end of file -- GitLab From 7d6c2cc8ecf48e30e9cbefcac80cec0a99e4e919 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 25 May 2021 18:12:55 +0100 Subject: [PATCH 22/33] Consumes extra stack --- .../interpreter_workload.ml | 5 +++ .../lib_protocol/michelson_v1_gas.ml | 4 +- .../lib_protocol/michelson_v1_gas.mli | 4 +- .../lib_protocol/michelson_v1_primitives.ml | 8 ++-- .../lib_protocol/script_interpreter.ml | 18 +++------ .../lib_protocol/script_ir_translator.ml | 39 +++++++------------ .../lib_protocol/script_typed_ir.ml | 16 +++++--- .../lib_protocol/test/test_global_counter.ml | 1 + 8 files changed, 46 insertions(+), 49 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml index 30bc30ab0bc..74ef41ec164 100644 --- a/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/interpreter_workload.ml @@ -1278,6 +1278,9 @@ module Instructions = struct let halt = ir_sized_step N_IHalt nullary let log = ir_sized_step N_ILog nullary + + (* TODO: Joel set gas amount *) + let increment_global_counter = ir_sized_step N_ILog nullary end module Control = struct @@ -1753,6 +1756,8 @@ let extract_ir_sized_step : Instructions.halt | (ILog _, _) -> Instructions.log + | (IIncrement_global_counter _, _) -> + Instructions.increment_global_counter let extract_control_trace (type bef_top bef aft_top aft) (cont : (bef_top, bef, aft_top, aft) Script_typed_ir.continuation) = diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 207401a8683..5ed50824979 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -1368,7 +1368,7 @@ module Cost_of = struct (int_bytes ticket_a.amount) (int_bytes ticket_b.amount)) - (* TODO: Joel what to set the gas cost to? *) + (* TODO: Joel - how to calculate gas cost? *) let increment_global_counter = S.safe_int 100 (* Continuations *) @@ -1823,4 +1823,4 @@ module Cost_of = struct let cms = List.length d.commitments_and_ciphertexts in atomic_step_cost (cost_SAPLING_DIFF_ENCODING ~nfs ~cms) end -end \ No newline at end of file +end diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli index fda705fb803..04fa5cb7b9e 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli @@ -344,8 +344,6 @@ module Cost_of : sig val transfer_tokens : Gas.cost - val increment_global_counter : Gas.cost - val implicit_account : Gas.cost val create_contract : Gas.cost @@ -393,6 +391,8 @@ module Cost_of : sig 'a Script_typed_ir.ticket -> Gas.cost + val increment_global_counter : Gas.cost + module Control : sig val nil : Gas.cost diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 0a3791dc22d..1f86fcc1f07 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -244,6 +244,7 @@ let namespace = function | I_ISNAT | I_ITER | I_JOIN_TICKETS + | I_INCREMENT_GLOBAL_COUNTER | I_KECCAK | I_LAMBDA | I_LE @@ -297,8 +298,7 @@ let namespace = function | I_UNPAIR | I_UPDATE | I_VOTING_POWER - | I_XOR - | I_INCREMENT_GLOBAL_COUNTER -> + | I_XOR -> Instr_namespace | T_address | T_big_map @@ -1119,8 +1119,8 @@ let prim_encoding = ("READ_TICKET", I_READ_TICKET); ("SPLIT_TICKET", I_SPLIT_TICKET); ("JOIN_TICKETS", I_JOIN_TICKETS); - ("GET_AND_UPDATE", I_GET_AND_UPDATE); - ("INCREMENT_GLOBAL_COUNTER", I_INCREMENT_GLOBAL_COUNTER) + ("INCREMENT_GLOBAL_COUNTER", I_INCREMENT_GLOBAL_COUNTER); + ("GET_AND_UPDATE", I_GET_AND_UPDATE) (* New instructions must be added here, for backward compatibility of the encoding. *) (* Keep the comment above at the end of the list *) ] diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index b414082ff50..dfd44929c03 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1385,11 +1385,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IIncrement_global_counter _ -> - - - let delegate = accu in - let operation = Delegation delegate in + | IIncrement_global_counter (_, k) -> + let operation = Global_counter_increment in let ctxt = update_context gas ctxt in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> @@ -1398,12 +1395,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let gas = update_local_gas_counter ctxt in let ctxt = outdated ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack ) - - - - fresh_internal_nonce ctxt +(* fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let operation = Internal_operation @@ -1413,7 +1407,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = nonce; } in - logged_return (((operation, None), rest), ctxt)) + logged_return (((operation, None), rest), ctxt)) *) (* @@ -1705,4 +1699,4 @@ module Internals = struct let step (ctxt, step_constants) gas ks accu stack = internal_step ctxt step_constants gas ks accu stack -end \ No newline at end of file +end diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 60e45da3259..d5af6a9d9d9 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5471,15 +5471,9 @@ and parse_instr : Item_t (Option_t (Key_hash_t _, _), rest, _) ) -> parse_var_annot loc annot >>?= fun annot -> - typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot)) - | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), rest) -> - parse_var_annot loc annot - >>?= fun annot -> - typed - ctxt - loc - IIncrement_global_counter - (Item_t (Operation_t None, rest, annot)) + let instr = {apply = (fun kinfo k -> ISet_delegate (kinfo, k))} in + let stack = Item_t (Operation_t None, rest, annot) in + typed ctxt 0 loc instr stack | (Prim (_, I_CREATE_ACCOUNT, _, _), _) -> fail (Deprecated_instruction I_CREATE_ACCOUNT) | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _)) @@ -5894,15 +5888,15 @@ and parse_instr : let stack = Item_t (Option_t (ty, None), rest, annot) in typed ctxt 0 loc instr stack | _ -> - (* TODO: fix injectivity of types *) assert false) - | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), rest) -> - parse_var_annot loc annot - >>?= fun annot -> - typed - ctxt - loc - Increment_global_counter - (Item_t (Operation_t None, rest, annot)) + (* TODO: fix injectivity of types *) assert false ) + | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), Item_t (_, rest, _)) -> + (* TODO: Joel - do we really need to peel off first layer? *) + parse_var_annot loc annot + >>?= fun annot -> let instr = + {apply = (fun kinfo k -> IIncrement_global_counter (kinfo, k))} + in + let stack = Item_t (Operation_t None, rest, annot) in + typed ctxt 0 loc instr stack (* Primitive parsing errors *) | ( Prim ( loc, @@ -5972,8 +5966,7 @@ and parse_instr : | I_TICKET | I_READ_TICKET | I_SPLIT_TICKET - | I_JOIN_TICKETS - | I_INCREMENT_GLOBAL_COUNTER) as name ), + | I_JOIN_TICKETS ) as name ), (_ :: _ as l), _ ), _ ) -> @@ -6116,8 +6109,7 @@ and parse_instr : | I_KECCAK | I_SHA3 | I_READ_TICKET - | I_JOIN_TICKETS - | I_INCREMENT_GLOBAL_COUNTER) as name ), + | I_JOIN_TICKETS ) as name ), _, _ ), stack ) -> @@ -6243,8 +6235,7 @@ and parse_instr : I_TICKET; I_READ_TICKET; I_SPLIT_TICKET; - I_JOIN_TICKETS; - I_INCREMENT_GLOBAL_COUNTER ] + I_JOIN_TICKETS ] and parse_contract : type arg. diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 9759aa9f428..b5321374fb8 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -923,6 +923,13 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = * 'a comparable_ty * ('a ticket option, 's, 'r, 'f) kinstr -> ('a ticket * 'a ticket, 's, 'r, 'f) kinstr + (* | ITransfer_tokens : + ('a, Tez.t * ('a typed_contract * 's)) kinfo + * (operation, 's, 'r, 'f) kinstr + -> ('a, Tez.t * ('a typed_contract * 's), 'r, 'f) kinstr *) + | IIncrement_global_counter : + ('a, 's) kinfo * (operation, 's, 'r, 'f) kinstr + -> ('a, 's, 'r, 'f) kinstr (* Internal control instructions @@ -934,8 +941,7 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = | IHalt : ('a, 's) kinfo -> ('a, 's, 'a, 's) kinstr | ILog : ('a, 's) kinfo * logging_event * logger * ('a, 's, 'r, 'f) kinstr - -> ('a, 's, 'r, 'f) kinstr - | IIncrement_global_counter : ('a, 's) kinfo -> ('a, 's, 'r, operation * 'r) kinstr + -> ('a, 's, 'r, 'f) kinstr and logging_event = | LogEntry : logging_event @@ -1572,7 +1578,7 @@ let kinfo_of_kinstr : type a s b f. (a, s, b, f) kinstr -> (a, s) kinfo = kinfo | ILog (kinfo, _, _, _) -> kinfo - | IIncrement_global_counter kinfo -> + | IIncrement_global_counter (kinfo, _) -> kinfo type kinstr_rewritek = { @@ -1909,5 +1915,5 @@ let kinstr_rewritek : IHalt kinfo | ILog (kinfo, event, logger, k) -> ILog (kinfo, event, logger, k) - | IIncrement_global_counter kinfo -> - IIncrement_global_counter kinfo \ No newline at end of file + | IIncrement_global_counter (kinfo, k) -> + IIncrement_global_counter (kinfo, k) diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index 9c8ae50b227..b045c761f5c 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -40,6 +40,7 @@ let call_contract_with_increment_global_counater () = code { CAR; NIL operation; + NIL operation; INCREMENT_GLOBAL_COUNTER; CONS; PAIR; } -- GitLab From a8c0fd159579f93fcff8c73be0ac0aea8acb3a4b Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 25 May 2021 18:47:59 +0100 Subject: [PATCH 23/33] Fix stack representation --- src/proto_alpha/lib_protocol/script_interpreter.ml | 2 +- src/proto_alpha/lib_protocol/script_ir_translator.ml | 6 +++--- src/proto_alpha/lib_protocol/script_typed_ir.ml | 6 +----- src/proto_alpha/lib_protocol/test/test_global_counter.ml | 1 - 4 files changed, 5 insertions(+), 10 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index dfd44929c03..fbef2263754 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1395,7 +1395,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let gas = update_local_gas_counter ctxt in let ctxt = outdated ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack ) + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res (accu, stack) ) (* fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d5af6a9d9d9..d5c22297191 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5889,10 +5889,10 @@ and parse_instr : typed ctxt 0 loc instr stack | _ -> (* TODO: fix injectivity of types *) assert false ) - | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), Item_t (_, rest, _)) -> - (* TODO: Joel - do we really need to peel off first layer? *) + | (Prim (loc, I_INCREMENT_GLOBAL_COUNTER, [], annot), rest) -> parse_var_annot loc annot - >>?= fun annot -> let instr = + >>?= fun annot -> + let instr = {apply = (fun kinfo k -> IIncrement_global_counter (kinfo, k))} in let stack = Item_t (Operation_t None, rest, annot) in diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index b5321374fb8..e0a78cb27dc 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -923,12 +923,8 @@ and ('before_top, 'before, 'result_top, 'result) kinstr = * 'a comparable_ty * ('a ticket option, 's, 'r, 'f) kinstr -> ('a ticket * 'a ticket, 's, 'r, 'f) kinstr - (* | ITransfer_tokens : - ('a, Tez.t * ('a typed_contract * 's)) kinfo - * (operation, 's, 'r, 'f) kinstr - -> ('a, Tez.t * ('a typed_contract * 's), 'r, 'f) kinstr *) | IIncrement_global_counter : - ('a, 's) kinfo * (operation, 's, 'r, 'f) kinstr + ('a, 's) kinfo * (operation, 'a * 's, 'r, 'f) kinstr -> ('a, 's, 'r, 'f) kinstr (* diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index b045c761f5c..9c8ae50b227 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -40,7 +40,6 @@ let call_contract_with_increment_global_counater () = code { CAR; NIL operation; - NIL operation; INCREMENT_GLOBAL_COUNTER; CONS; PAIR; } -- GitLab From a89a0add026a014e1787f9b514ff61e577dd43c6 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Tue, 25 May 2021 21:43:35 +0100 Subject: [PATCH 24/33] Format --- src/proto_alpha/lib_protocol/script_interpreter.ml | 12 ------------ .../lib_protocol/script_interpreter_defs.ml | 2 +- 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index fbef2263754..68bbdb512d5 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1397,18 +1397,6 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let ctxt = outdated ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res (accu, stack) ) -(* fresh_internal_nonce ctxt - >>?= fun (ctxt, nonce) -> - let operation = - Internal_operation - { - source = step_constants.self; - operation = Global_counter_increment; - nonce; - } - in - logged_return (((operation, None), rest), ctxt)) *) - (* Zero-cost logging diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 79df2045d0e..83a9eb70ead 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -439,7 +439,7 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = | ILog _ -> Gas.free | IIncrement_global_counter _ -> - Interp_costs.increment_global_counter + Interp_costs.increment_global_counter [@@ocaml.inline always] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = -- GitLab From 0bf5ccc86120a40c3f4250d50c1e186e626e115f Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 09:41:45 +0100 Subject: [PATCH 25/33] Decrease gas limit --- .../lib_protocol/test/test_global_counter.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index 9c8ae50b227..0b5a6e7236b 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -8,14 +8,14 @@ let make_contract ~code ~originator ~amount ~block = let code = AC.Script.lazy_expr @@ Expr.from_string code in let amount = AC.Tez.of_mutez_exn (Int64.of_int amount) in Incremental.begin_construction block - >>=? fun b -> + >>=? fun block -> let script = Op.{dummy_script with code} in - Op.origination (I b) originator ~script ~credit:amount + Op.origination (I block) originator ~script ~credit:amount >>=? fun (op, originated_contract) -> - Incremental.add_operation b op - >>=? fun b -> - Incremental.finalize_block b - >>=? fun b -> Error_monad.return (b, originated_contract) + Incremental.add_operation block op + >>=? fun block -> + Incremental.finalize_block block + |> Lwt_result.map (fun block -> (block, originated_contract)) let transfer block ~sender ~recipient ~amount ~entrypoint = Incremental.begin_construction block @@ -64,7 +64,7 @@ let global_counter_initially_zero () = >>=? fun n -> Assert.equal_int32 ~loc:__LOC__ 0l n let repeat_increment_counter block contract n = - let gas_limit = AC.Gas.Arith.integral_of_int_exn 10_000 in + let gas_limit = AC.Gas.Arith.integral_of_int_exn 1000 in let rec increment_n n inc = if n <= 0 then return inc else -- GitLab From 5c19b4be4582e7db86fe787c2c761eac1ccceccd Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 09:50:54 +0100 Subject: [PATCH 26/33] F --- .../lib_protocol/test/test_global_counter.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index 0b5a6e7236b..1bdb1de04c7 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -2,15 +2,19 @@ module AC = Protocol.Alpha_context let register_contract () = Context.init 1 - >|=? function (block, [contract]) -> (block, contract) | _ -> assert false + >>=? function + | (block, [contract]) -> + return (block, contract) + | _ -> + Error_monad.failwith "Expected single contract" let make_contract ~code ~originator ~amount ~block = - let code = AC.Script.lazy_expr @@ Expr.from_string code in - let amount = AC.Tez.of_mutez_exn (Int64.of_int amount) in Incremental.begin_construction block >>=? fun block -> + let code = AC.Script.lazy_expr @@ Expr.from_string code in + let credit = AC.Tez.of_mutez_exn (Int64.of_int amount) in let script = Op.{dummy_script with code} in - Op.origination (I block) originator ~script ~credit:amount + Op.origination (I block) originator ~script ~credit >>=? fun (op, originated_contract) -> Incremental.add_operation block op >>=? fun block -> -- GitLab From 609c7c632bcd90bb23deb52d289e75abe16aefc5 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 10:06:02 +0100 Subject: [PATCH 27/33] Remove storage limit argument --- .../lib_client/client_proto_context.ml | 15 +++++---------- .../lib_client/client_proto_context.mli | 1 - .../client_proto_context_commands.ml | 7 +------ 3 files changed, 6 insertions(+), 17 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index 5425e619c20..ac30b841147 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -148,23 +148,18 @@ let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run | Apply_results.Single_and_result ((Manager_operation _ as op), result) -> return ((oph, op, result), contracts) -let build_incremenent_global_counter_operation ?fee ?gas_limit ?storage_limit - () = +let build_incremenent_global_counter_operation ?fee ?gas_limit () = Injection.prepare_manager_operation ~fee:(Limit.of_option fee) ~gas_limit:(Limit.of_option gas_limit) - ~storage_limit:(Limit.of_option storage_limit) + ~storage_limit:(Limit.of_option None) Global_counter_increment let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch ~source ~src_pk ~src_sk ?fee ?gas_limit - ?storage_limit ?counter ~fee_parameter () = + ?counter ~fee_parameter () = let contents = - build_incremenent_global_counter_operation - ?fee - ?gas_limit - ?storage_limit - () + build_incremenent_global_counter_operation ?fee ?gas_limit () in let contents = Annotated_manager_operation.Single_manager contents in Injection.inject_manager_operation @@ -178,7 +173,7 @@ let increment_global_counter (cctxt : #full) ~chain ~block ?confirmations ~source ~fee:(Limit.of_option fee) ~gas_limit:(Limit.of_option gas_limit) - ~storage_limit:(Limit.of_option storage_limit) + ~storage_limit:(Limit.of_option None) ?counter ~src_pk ~src_sk diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index f7295f9dd74..8929a428397 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -200,7 +200,6 @@ val increment_global_counter : src_sk:Client_keys.sk_uri -> ?fee:Tez.t -> ?gas_limit:Fixed_point_repr.integral_tag Gas.Arith.t -> - ?storage_limit:counter -> ?counter:counter -> fee_parameter:Injection.fee_parameter -> unit -> diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 7ab6409bfea..45dd58cd84e 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -119,7 +119,6 @@ let increment_global_counter_command source cctxt dry_run, verbose_signing, gas_limit, - storage_limit, counter, no_print_source, minimal_fees, @@ -161,7 +160,6 @@ let increment_global_counter_command source cctxt ~src_pk ~src_sk ?gas_limit - ?storage_limit ?counter () >>= report_michelson_errors @@ -1071,12 +1069,11 @@ let commands network () = command ~group ~desc:"Increment global counter." - (args13 + (args12 fee_arg dry_run_switch verbose_signing_switch gas_limit_arg - storage_limit_arg counter_arg no_print_source_flag minimal_fees_arg @@ -1094,7 +1091,6 @@ let commands network () = dry_run, verbose_signing, gas_limit, - storage_limit, counter, no_print_source, minimal_fees, @@ -1112,7 +1108,6 @@ let commands network () = dry_run, verbose_signing, gas_limit, - storage_limit, counter, no_print_source, minimal_fees, -- GitLab From df70c5b09deb8c47378c5c0340d5b8948591f316 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 10:09:00 +0100 Subject: [PATCH 28/33] Fix typo --- .../lib_client_commands/client_proto_context_commands.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index 45dd58cd84e..1a8cda28bf3 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -164,7 +164,7 @@ let increment_global_counter_command source cctxt () >>= report_michelson_errors ~no_print_source - ~msg:"transfer simulation failed" + ~msg:"increment global counter simulation failed" cctxt >>= function None -> return_unit | Some (_res, _contracts) -> return_unit -- GitLab From 7170c762d9e1584ed1c7641bbecbcdbac3c2742f Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 10:12:36 +0100 Subject: [PATCH 29/33] Minor refactoring --- src/proto_alpha/lib_protocol/test/test_global_counter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_global_counter.ml b/src/proto_alpha/lib_protocol/test/test_global_counter.ml index 1bdb1de04c7..eab9bcfd58a 100644 --- a/src/proto_alpha/lib_protocol/test/test_global_counter.ml +++ b/src/proto_alpha/lib_protocol/test/test_global_counter.ml @@ -73,8 +73,8 @@ let repeat_increment_counter block contract n = if n <= 0 then return inc else Op.increment_global_counter ~gas_limit (I inc) contract - >>=? fun op -> - Incremental.add_operation inc op >>=? fun inc -> increment_n (n - 1) inc + >>=? Incremental.add_operation inc + >>=? increment_n (n - 1) in Incremental.begin_construction block >>=? increment_n n -- GitLab From 4848efd318dbd2851814c3b0e8e820645f316774 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 12:22:34 +0100 Subject: [PATCH 30/33] Client tezts --- tezt/lib_tezos/client.ml | 19 +++++++++++++++++++ tezt/lib_tezos/client.mli | 5 +++++ tezt/tests/mockup.ml | 30 +++++++++++++++++++++++++++++- 3 files changed, 53 insertions(+), 1 deletion(-) diff --git a/tezt/lib_tezos/client.ml b/tezt/lib_tezos/client.ml index d8822ad07dd..646ab952c96 100644 --- a/tezt/lib_tezos/client.ml +++ b/tezt/lib_tezos/client.ml @@ -428,6 +428,15 @@ let withdraw_delegate ?node ?wait ~src client = let spawn_get_balance_for ?node ~account client = spawn_command ?node client ["get"; "balance"; "for"; account] +let spawn_get_global_counter ?node client = + spawn_command ?node client ["get"; "global-counter"] + +let spawn_increment_global_counter ?node ~gas_limit ~account client = + spawn_command + ?node + client + ["increment-global-counter"; account; "--gas-limit"; gas_limit] + let get_balance_for ?node ~account client = let extract_balance (client_output : string) : float = match client_output =~* rex "(\\d+(?:\\.\\d+)?) \u{A729}" with @@ -441,6 +450,16 @@ let get_balance_for ?node ~account client = and* output = Lwt_io.read (Process.stdout process) in return @@ extract_balance output +let get_global_counter ?node client = + let process = spawn_get_global_counter ?node client in + let* () = Process.check process + and* output = Lwt_io.read (Process.stdout process) in + return @@ int_of_string @@ String.trim output + +let increment_global_counter ?node ~account ~gas_limit client = + spawn_increment_global_counter ?node ~account ~gas_limit client + |> Process.check + let spawn_create_mockup ?(sync_mode = Synchronous) ?constants ~protocol client = let cmd = diff --git a/tezt/lib_tezos/client.mli b/tezt/lib_tezos/client.mli index 9ac03293209..563d86c4283 100644 --- a/tezt/lib_tezos/client.mli +++ b/tezt/lib_tezos/client.mli @@ -324,9 +324,14 @@ val spawn_withdraw_delegate : (** Run [tezos-client get balance for]. *) val get_balance_for : ?node:Node.t -> account:string -> t -> float Lwt.t +val get_global_counter : ?node:Node.t -> t -> int Lwt.t + (** Same as [get_balance_for], but do not wait for the process to exit. *) val spawn_get_balance_for : ?node:Node.t -> account:string -> t -> Process.t +val increment_global_counter : + ?node:Node.t -> account:string -> gas_limit:string -> t -> unit Lwt.t + (** Run [tezos-client create mockup]. *) val create_mockup : ?sync_mode:mockup_sync_mode -> diff --git a/tezt/tests/mockup.ml b/tezt/tests/mockup.ml index ec3b965a0c2..49dd0dc3379 100644 --- a/tezt/tests/mockup.ml +++ b/tezt/tests/mockup.ml @@ -508,6 +508,33 @@ let test_origination_from_unrevealed_fees = in return () +let test_increment_global_counter = + Protocol.register_test + ~__FILE__ + ~title:"(Mockup) Increment global counter" + ~tags:["mockup"; "client"; "increment"; "global"; "counter"] + @@ fun protocol -> + match protocol with + | Alpha -> + let (account, _, _) = transfer_data in + let* client = Client.init_mockup ~protocol () in + let* n = Client.get_global_counter client in + if n <> 0 then + Test.fail "Expected initial global counter to be 0 but got %d" n ; + let* () = + Client.increment_global_counter ~account ~gas_limit:"1000" client + in + let* n = Client.get_global_counter client in + if n <> 1 then Test.fail "Expected global counter to be 1 but got %d" n ; + let* () = + Client.increment_global_counter ~account ~gas_limit:"1000" client + in + let* n = Client.get_global_counter client in + if n <> 2 then Test.fail "Expected global counter to be 2 but got %d" n ; + return () + | _ -> + return () + let register ~protocols = test_rpc_list ~protocols ; test_same_transfer_twice ~protocols ; @@ -516,7 +543,8 @@ let register ~protocols = test_simple_baking_event ~protocols ; test_multiple_baking ~protocols ; test_rpc_header_shell ~protocols ; - test_origination_from_unrevealed_fees ~protocols + test_origination_from_unrevealed_fees ~protocols ; + test_increment_global_counter ~protocols let register_constant_migration ~migrate_from ~migrate_to = test_migration_constants ~migrate_from ~migrate_to -- GitLab From 2458d1ebbf594714ee5e0fc82dc7e3b2884e93ad Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 15:51:45 +0100 Subject: [PATCH 31/33] Add a mockup client test for calling a contract --- .../proto_alpha/increment_global_counter.tz | 3 ++ tezt/tests/mockup.ml | 48 +++++++++++++++++++ 2 files changed, 51 insertions(+) create mode 100644 tezt/tests/contracts/proto_alpha/increment_global_counter.tz diff --git a/tezt/tests/contracts/proto_alpha/increment_global_counter.tz b/tezt/tests/contracts/proto_alpha/increment_global_counter.tz new file mode 100644 index 00000000000..8cf3b85ac4b --- /dev/null +++ b/tezt/tests/contracts/proto_alpha/increment_global_counter.tz @@ -0,0 +1,3 @@ +parameter string; +storage string; +code {CAR; NIL operation; INCREMENT_GLOBAL_COUNTER; CONS; PAIR; }; diff --git a/tezt/tests/mockup.ml b/tezt/tests/mockup.ml index 49dd0dc3379..bf0ef3917cd 100644 --- a/tezt/tests/mockup.ml +++ b/tezt/tests/mockup.ml @@ -535,6 +535,53 @@ let test_increment_global_counter = | _ -> return () +let verify_global_counter client expected = + let* n = Client.get_global_counter client in + if n <> expected then + Test.fail "Expected global counter to be %d but got %d" expected n + else return () + +let test_call_contract_with_increment_global_counter = + Protocol.register_test + ~__FILE__ + ~title:"(Mockup) Call conttract with increment global counter operation" + ~tags:["mockup"; "client"; "increment"; "global"; "counter"] + @@ fun protocol -> + match protocol with + | Alpha -> + let* client = Client.init_mockup ~protocol () in + let* () = verify_global_counter client 0 in + Log.info "Originate new contract that updates the global counter" ; + let* _ = + Client.originate_contract + ~alias:"increment_global_counter" + ~amount:Tez.zero + ~src:"bootstrap1" + ~prg: + "file:./tezt/tests/contracts/proto_alpha/increment_global_counter.tz" + ~init:{|""|} + ~burn_cap:(Tez.of_int 2) + client + in + let* () = Client.bake_for ~key:"bootstrap1" client in + Log.info "Call the contract for incrementing the counter" ; + let* () = + Client.transfer + ~amount:Tez.zero + ~giver:"bootstrap1" + ~receiver:"increment_global_counter" + ~arg:{|"Hello"|} + ~burn_cap:(Tez.of_int 1) + ~gas_limit:10_000 + client + in + let* () = Client.bake_for ~key:"bootstrap1" client in + Log.info "Verify that the counter has been incremented" ; + let* () = verify_global_counter client 1 in + return () + | _ -> + return () + let register ~protocols = test_rpc_list ~protocols ; test_same_transfer_twice ~protocols ; @@ -544,6 +591,7 @@ let register ~protocols = test_multiple_baking ~protocols ; test_rpc_header_shell ~protocols ; test_origination_from_unrevealed_fees ~protocols ; + test_call_contract_with_increment_global_counter ~protocols ; test_increment_global_counter ~protocols let register_constant_migration ~migrate_from ~migrate_to = -- GitLab From 5106253e714280abcadfbe33fcdaa1a08c97fbe9 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 16:06:59 +0100 Subject: [PATCH 32/33] Minor refactoring --- tezt/tests/mockup.ml | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/tezt/tests/mockup.ml b/tezt/tests/mockup.ml index bf0ef3917cd..45a9c5310da 100644 --- a/tezt/tests/mockup.ml +++ b/tezt/tests/mockup.ml @@ -508,6 +508,12 @@ let test_origination_from_unrevealed_fees = in return () +let verify_global_counter client expected = + let* n = Client.get_global_counter client in + if n <> expected then + Test.fail "Expected global counter to be %d but got %d" expected n + else return () + let test_increment_global_counter = Protocol.register_test ~__FILE__ @@ -518,29 +524,18 @@ let test_increment_global_counter = | Alpha -> let (account, _, _) = transfer_data in let* client = Client.init_mockup ~protocol () in - let* n = Client.get_global_counter client in - if n <> 0 then - Test.fail "Expected initial global counter to be 0 but got %d" n ; + let* () = verify_global_counter client 0 in let* () = Client.increment_global_counter ~account ~gas_limit:"1000" client in - let* n = Client.get_global_counter client in - if n <> 1 then Test.fail "Expected global counter to be 1 but got %d" n ; + let* () = verify_global_counter client 1 in let* () = Client.increment_global_counter ~account ~gas_limit:"1000" client in - let* n = Client.get_global_counter client in - if n <> 2 then Test.fail "Expected global counter to be 2 but got %d" n ; - return () + verify_global_counter client 2 | _ -> return () -let verify_global_counter client expected = - let* n = Client.get_global_counter client in - if n <> expected then - Test.fail "Expected global counter to be %d but got %d" expected n - else return () - let test_call_contract_with_increment_global_counter = Protocol.register_test ~__FILE__ -- GitLab From 7ece7dfabaa8dcf42a6a7e998bf62e23aa9f6c49 Mon Sep 17 00:00:00 2001 From: Joel Bjornson Date: Wed, 26 May 2021 16:12:32 +0100 Subject: [PATCH 33/33] Refactor tests --- tezt/tests/mockup.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tezt/tests/mockup.ml b/tezt/tests/mockup.ml index 45a9c5310da..876f47a51e2 100644 --- a/tezt/tests/mockup.ml +++ b/tezt/tests/mockup.ml @@ -545,7 +545,6 @@ let test_call_contract_with_increment_global_counter = match protocol with | Alpha -> let* client = Client.init_mockup ~protocol () in - let* () = verify_global_counter client 0 in Log.info "Originate new contract that updates the global counter" ; let* _ = Client.originate_contract @@ -559,6 +558,8 @@ let test_call_contract_with_increment_global_counter = client in let* () = Client.bake_for ~key:"bootstrap1" client in + Log.info "Verify that the global counter is initially zero" ; + let* () = verify_global_counter client 0 in Log.info "Call the contract for incrementing the counter" ; let* () = Client.transfer @@ -572,8 +573,7 @@ let test_call_contract_with_increment_global_counter = in let* () = Client.bake_for ~key:"bootstrap1" client in Log.info "Verify that the counter has been incremented" ; - let* () = verify_global_counter client 1 in - return () + verify_global_counter client 1 | _ -> return () -- GitLab